[Koha-cvs] koha/C4 Accounts2.pm Acquisition.pm Amazon.pm A...
paul poulain
paul at koha-fr.org
Fri Mar 9 15:31:49 CET 2007
CVSROOT: /sources/koha
Module name: koha
Changes by: paul poulain <tipaul> 07/03/09 14:31:47
Modified files:
C4 : Accounts2.pm Acquisition.pm Amazon.pm Auth.pm
Auth_with_ldap.pm AuthoritiesMarc.pm Biblio.pm
BookShelves.pm Bookfund.pm Bookseller.pm
Breeding.pm Context.pm Date.pm Input.pm Koha.pm
Labels.pm Letters.pm Log.pm Members.pm
NewsChannels.pm Output.pm Print.pm Reserves2.pm
Review.pm Search.pm Serials.pm Stats.pm
Suggestions.pm Z3950.pm
Log message:
rel_3_0 moved to HEAD
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Accounts2.pm?cvsroot=koha&r1=1.34&r2=1.35
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Acquisition.pm?cvsroot=koha&r1=1.48&r2=1.49
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Amazon.pm?cvsroot=koha&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Auth.pm?cvsroot=koha&r1=1.57&r2=1.58
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Auth_with_ldap.pm?cvsroot=koha&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/koha/C4/AuthoritiesMarc.pm?cvsroot=koha&r1=1.37&r2=1.38
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Biblio.pm?cvsroot=koha&r1=1.187&r2=1.188
http://cvs.savannah.gnu.org/viewcvs/koha/C4/BookShelves.pm?cvsroot=koha&r1=1.19&r2=1.20
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Bookfund.pm?cvsroot=koha&r1=1.7&r2=1.8
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Bookseller.pm?cvsroot=koha&r1=1.1&r2=1.2
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Breeding.pm?cvsroot=koha&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Context.pm?cvsroot=koha&r1=1.50&r2=1.51
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Date.pm?cvsroot=koha&r1=1.24&r2=1.25
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Input.pm?cvsroot=koha&r1=1.21&r2=1.22
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Koha.pm?cvsroot=koha&r1=1.47&r2=1.48
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Labels.pm?cvsroot=koha&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Letters.pm?cvsroot=koha&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Log.pm?cvsroot=koha&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Members.pm?cvsroot=koha&r1=1.39&r2=1.40
http://cvs.savannah.gnu.org/viewcvs/koha/C4/NewsChannels.pm?cvsroot=koha&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Output.pm?cvsroot=koha&r1=1.59&r2=1.60
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Print.pm?cvsroot=koha&r1=1.18&r2=1.19
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Reserves2.pm?cvsroot=koha&r1=1.49&r2=1.50
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Review.pm?cvsroot=koha&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Search.pm?cvsroot=koha&r1=1.126&r2=1.127
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Serials.pm?cvsroot=koha&r1=1.11&r2=1.12
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Stats.pm?cvsroot=koha&r1=1.28&r2=1.29
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Suggestions.pm?cvsroot=koha&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Z3950.pm?cvsroot=koha&r1=1.13&r2=1.14
Patches:
Index: Accounts2.pm
===================================================================
RCS file: /sources/koha/koha/C4/Accounts2.pm,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -b -r1.34 -r1.35
--- Accounts2.pm 27 Sep 2006 19:53:52 -0000 1.34
+++ Accounts2.pm 9 Mar 2007 14:31:47 -0000 1.35
@@ -18,18 +18,19 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+# $Id: Accounts2.pm,v 1.35 2007/03/09 14:31:47 tipaul Exp $
+
use strict;
require Exporter;
use C4::Context;
use C4::Stats;
-use C4::Search;
-use C4::Circulation::Circ2;
use C4::Members;
+#use C4::Circulation::Circ2;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01; # FIXME - Should probably be different from
- # the version for C4::Accounts
+$VERSION = do { my @v = '$Revision: 1.35 $' =~ /\d+/g;
+shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
=head1 NAME
@@ -47,17 +48,13 @@
=head1 FUNCTIONS
-=over 2
-
=cut
@ISA = qw(Exporter);
@EXPORT = qw(&checkaccount &recordpayment &fixaccounts &makepayment &manualinvoice
- &getnextacctno &manualcredit
-
- &dailyAccountBalance &addDailyAccountOp &getDailyAccountOp);
+&getnextacctno &reconcileaccount);
-=item checkaccount
+=head2 checkaccount
$owed = &checkaccount($env, $borrowernumber, $dbh, $date);
@@ -70,17 +67,18 @@
C<$env> is ignored.
=cut
+
#'
sub checkaccount {
#take borrower number
#check accounts and list amounts owing
- my ($env,$bornumber,$dbh,$date)=@_;
+ my ($env,$borrowernumber,$dbh,$date)=@_;
my $select="SELECT SUM(amountoutstanding) AS total
FROM accountlines
WHERE borrowernumber = ?
AND amountoutstanding<>0";
- my @bind = ($bornumber);
- if ($date ne ''){
+ my @bind = ($borrowernumber);
+ if ($date && $date ne ''){
$select.=" AND date < ?";
push(@bind,$date);
}
@@ -88,20 +86,20 @@
my $sth=$dbh->prepare($select);
$sth->execute(@bind);
my $data=$sth->fetchrow_hashref;
- my $total = $data->{'total'};
+ my $total = $data->{'total'} || 0;
$sth->finish;
# output(1,2,"borrower owes $total");
#if ($total > 0){
# # output(1,2,"borrower owes $total");
# if ($total > 5){
- # reconcileaccount($env,$dbh,$bornumber,$total);
+ # reconcileaccount($env,$dbh,$borrowernumber,$total);
# }
#}
# pause();
return($total);
}
-=item recordpayment
+=head2 recordpayment
&recordpayment($env, $borrowernumber, $payment);
@@ -117,22 +115,24 @@
will be credited to the next one.
=cut
+
#'
sub recordpayment{
#here we update both the accountoffsets and the account lines
- my ($env,$bornumber,$data)=@_;
+ my ($env,$borrowernumber,$data)=@_;
my $dbh = C4::Context->dbh;
my $newamtos = 0;
my $accdata = "";
my $branch=$env->{'branchcode'};
+ warn $branch;
my $amountleft = $data;
# begin transaction
- my $nextaccntno = getnextacctno($env,$bornumber,$dbh);
+ my $nextaccntno = getnextacctno($env,$borrowernumber,$dbh);
# get lines with outstanding amounts to offset
my $sth = $dbh->prepare("select * from accountlines
where (borrowernumber = ?) and (amountoutstanding<>0)
order by date");
- $sth->execute($bornumber);
+ $sth->execute($borrowernumber);
# offset transactions
while (($accdata=$sth->fetchrow_hashref) and ($amountleft>0)){
if ($accdata->{'amountoutstanding'} < $amountleft) {
@@ -142,105 +142,98 @@
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
- my $thisacct = $accdata->{accountid};
+ my $thisacct = $accdata->{accountno};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
- where accountid=?");
- $usth->execute($newamtos,$thisacct);
+ where (borrowernumber = ?) and (accountno=?)");
+ $usth->execute($newamtos,$borrowernumber,$thisacct);
+ $usth->finish;
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)");
+ $usth->execute($borrowernumber,$accdata->{'accountno'},$nextaccntno,$newamtos);
$usth->finish;
}
# create new line
my $usth = $dbh->prepare("insert into accountlines
(borrowernumber, accountno,date,amount,description,accounttype,amountoutstanding)
values (?,?,now(),?,'Payment,thanks','Pay',?)");
- $usth->execute($bornumber,$nextaccntno,0-$data,0-$amountleft);
+ $usth->execute($borrowernumber,$nextaccntno,0-$data,0-$amountleft);
$usth->finish;
-# UpdateStats($env,$branch,'payment',$data,'','','',$bornumber);
+ UpdateStats($env,$branch,'payment',$data,'','','',$borrowernumber);
$sth->finish;
}
-=item makepayment
+=head2 makepayment
&makepayment($borrowernumber, $acctnumber, $amount, $branchcode);
-Records the fact that a patron has paid off the an amount he or
+Records the fact that a patron has paid off the entire 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. C<$branchcode> is the code of the branch where payment
+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
was made.
=cut
+
#'
# FIXME - I'm not at all sure about the above, because I don't
# understand what the acct* tables in the Koha database are for.
-
sub makepayment{
- #here we update the account lines
+ #here we update both the accountoffsets and the account lines
#updated to check, if they are paying off a lost item, we return the item
# from their card, and put a note on the item record
- my ($bornumber,$accountno,$amount,$user,$type)=@_;
- my $env;
-my $desc;
-my $pay;
-if ($type eq "Pay"){
- $desc="Payment,received by -". $user;
- $pay="Pay";
-}else{
- $desc="Written-off -by". $user;
- $pay="W";
-}
+ my ($borrowernumber,$accountno,$amount,$user,$branch)=@_;
+ my %env;
+ $env{'branchcode'}=$branch;
my $dbh = C4::Context->dbh;
# begin transaction
- my $nextaccntno = getnextacctno($env,$bornumber,$dbh);
+ my $nextaccntno = getnextacctno(\%env,$borrowernumber,$dbh);
my $newamtos=0;
my $sth=$dbh->prepare("Select * from accountlines where borrowernumber=? and accountno=?");
- $sth->execute($bornumber,$accountno);
+ $sth->execute($borrowernumber,$accountno);
my $data=$sth->fetchrow_hashref;
$sth->finish;
$dbh->do(<<EOT);
UPDATE accountlines
- SET amountoutstanding = amountoutstanding-$amount
- WHERE borrowernumber = $bornumber
+ SET amountoutstanding = 0
+ WHERE borrowernumber = $borrowernumber
AND accountno = $accountno
EOT
-
+# print $updquery;
+ $dbh->do(<<EOT);
+ INSERT INTO accountoffsets
+ (borrowernumber, accountno, offsetaccount,
+ offsetamount)
+ VALUES ($borrowernumber, $accountno, $nextaccntno, $newamtos)
+EOT
# create new line
my $payment=0-$amount;
-if ($data->{'itemnumber'}){
-$desc.=" ".$data->{'itemnumber'};
-
$dbh->do(<<EOT);
INSERT INTO accountlines
- (borrowernumber, accountno, itemnumber,date, amount,
- description, accounttype, amountoutstanding,offset)
- VALUES ($bornumber, $nextaccntno, $data->{'itemnumber'},now(), $payment,
- '$desc', '$pay', 0,$accountno)
-EOT
-}else{
- $dbh->do(<<EOT);
-INSERT INTO accountlines
(borrowernumber, accountno, date, amount,
- description, accounttype, amountoutstanding,offset)
- VALUES ($bornumber, $nextaccntno, now(), $payment,
- '$desc', '$pay', 0,$accountno)
+ description, accounttype, amountoutstanding)
+ VALUES ($borrowernumber, $nextaccntno, now(), $payment,
+ 'Payment,thanks - $user', 'Pay', 0)
EOT
-}
# FIXME - The second argument to &UpdateStats is supposed to be the
# branch code.
-# UpdateStats($env,'MAIN',$pay,$amount,'','','',$bornumber);
+ # UpdateStats is now being passed $accountno too. MTJ
+ UpdateStats(\%env,$user,'payment',$amount,'','','',$borrowernumber,$accountno);
$sth->finish;
#check to see what accounttype
if ($data->{'accounttype'} eq 'Rep' || $data->{'accounttype'} eq 'L'){
- returnlost($bornumber,$data->{'itemnumber'});
+ returnlost($borrowernumber,$data->{'itemnumber'});
}
}
-=item getnextacctno
+=head2 getnextacctno
$nextacct = &getnextacctno($env, $borrowernumber, $dbh);
@@ -252,15 +245,16 @@
C<$env> is ignored.
=cut
+
#'
# FIXME - Okay, so what does the above actually _mean_?
sub getnextacctno {
- my ($env,$bornumber,$dbh)=@_;
+ my ($env,$borrowernumber,$dbh)=@_;
my $nextaccntno = 1;
my $sth = $dbh->prepare("select * from accountlines
where (borrowernumber = ?)
order by accountno desc");
- $sth->execute($bornumber);
+ $sth->execute($borrowernumber);
if (my $accdata=$sth->fetchrow_hashref){
$nextaccntno = $accdata->{'accountno'} + 1;
}
@@ -268,13 +262,14 @@
return($nextaccntno);
}
-=item fixaccounts
+=head2 fixaccounts
&fixaccounts($borrowernumber, $accountnumber, $amount);
=cut
+
#'
-# FIXME - I don't know whether used
+# FIXME - I don't understand what this function does.
sub fixaccounts {
my ($borrowernumber,$accountno,$amount)=@_;
my $dbh = C4::Context->dbh;
@@ -298,103 +293,126 @@
# FIXME - Never used, but not exported, either.
sub returnlost{
- my ($borrnum,$itemnum)=@_;
+ my ($borrowernumber,$itemnum)=@_;
my $dbh = C4::Context->dbh;
- my $borrower=C4::Members::borrdata('',$borrnum); #from C4::Members;
+ my $borrower=borrdata('',$borrowernumber);
my $sth=$dbh->prepare("Update issues set returndate=now() where
borrowernumber=? and itemnumber=? and returndate is null");
- $sth->execute($borrnum,$itemnum);
+ $sth->execute($borrowernumber,$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
+=head2 manualinvoice
- &manualinvoice($borrowernumber, $description, $type,
+ &manualinvoice($borrowernumber, $itemnumber, $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,$desc,$type,$amount,$user)=@_;
+ my ($borrowernumber,$itemnum,$desc,$type,$amount,$user)=@_;
my $dbh = C4::Context->dbh;
+ my $notifyid;
my $insert;
+ $itemnum=~ s/ //g;
my %env;
- my $accountno=getnextacctno('',$bornum,$dbh);
+ my $accountno=getnextacctno('',$borrowernumber,$dbh);
my $amountleft=$amount;
-
+ if ($type eq 'CS' || $type eq 'CB' || $type eq 'CW'
+ || $type eq 'CF' || $type eq 'CL'){
+ my $amount2=$amount*-1; # FIXME - $amount2 = -$amount
+ $amountleft=fixcredit(\%env,$borrowernumber,$amount2,$itemnum,$type,$user);
+ }
if ($type eq 'N'){
$desc.="New Card";
}
+ if ($type eq 'F'){
+ $desc.="Fine";
+ }
+ if ($type eq 'A'){
+ $desc.="Account Management fee";
+ }
+ if ($type eq 'M'){
+ $desc.="Sundry";
+ }
if ($type eq 'L' && $desc eq ''){
+
$desc="Lost Item";
}
if ($type eq 'REF'){
- $desc="Cash refund";
+ $desc.="Cash Refund";
+ $amountleft=refund('',$borrowernumber,$amount);
+ }
+ if(($type eq 'L') or ($type eq 'F') or ($type eq 'A') or ($type eq 'N') or ($type eq 'M') ){
+ $notifyid=1;
}
- $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);
+ if ($itemnum ne ''){
+ $desc.=" ".$itemnum;
+ my $sth=$dbh->prepare("INSERT INTO accountlines
+ (borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding, itemnumber,notify_id)
+ VALUES (?, ?, now(), ?,?, ?,?,?,?)");
+# $sth->execute($borrowernumber, $accountno, $amount, $desc, $type, $amountleft, $data->{'itemnumber'});
+ $sth->execute($borrowernumber, $accountno, $amount, $desc, $type, $amountleft, $itemnum,$notifyid);
+ } else {
+ my $sth=$dbh->prepare("INSERT INTO accountlines
+ (borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding,notify_id)
+ VALUES (?, ?, now(), ?, ?, ?, ?,?)");
+ $sth->execute($borrowernumber, $accountno, $amount, $desc, $type, $amountleft,$notifyid);
+ }
}
-sub manualcredit{
- my ($bornum,$accountid,$desc,$type,$amount,$user,$oldaccount)=@_;
- my $dbh = C4::Context->dbh;
- my $insert;
- 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;
- ( $amountleft, $noerror,$oldaccount)=fixcredit($dbh,$bornum,$amount2,$accountid,$type,$user);
- }
- if ($noerror>0){
-
-## 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;
+=head2 fixcredit
- 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);
+ $amountleft = &fixcredit($env, $borrowernumber, $data, $barcode, $type, $user);
+
+ This function is only used internally, not exported.
+ FIXME - Figure out what this function does, and write it down.
+
+=cut
-return ("0");
-} else {
- return("1");
-}
-}
-# fixcredit
sub fixcredit{
#here we update both the accountoffsets and the account lines
- my ($dbh,$bornumber,$data,$accountid,$type,$user)=@_;
+ my ($env,$borrowernumber,$data,$barcode,$type,$user)=@_;
+ my $dbh = C4::Context->dbh;
my $newamtos = 0;
my $accdata = "";
my $amountleft = $data;
- my $env;
- my $query="Select * from accountlines where accountid=? and amountoutstanding > 0";
+ if ($barcode ne ''){
+ my $item=getiteminformation('',$barcode);
+ my $nextaccntno = getnextacctno($env,$borrowernumber,$dbh);
+ my $query="Select * from accountlines where (borrowernumber=?
+ and itemnumber=? and amountoutstanding > 0)";
+ if ($type eq 'CL'){
+ $query.=" and (accounttype = 'L' or accounttype = 'Rep')";
+ } elsif ($type eq 'CF'){
+ $query.=" and (accounttype = 'F' or accounttype = 'FU' or
+ accounttype='Res' or accounttype='Rent')";
+ } elsif ($type eq 'CB'){
+ $query.=" and accounttype='A'";
+ }
+# print $query;
my $sth=$dbh->prepare($query);
-$sth->execute($accountid);
+ $sth->execute($borrowernumber,$item->{'itemnumber'});
$accdata=$sth->fetchrow_hashref;
$sth->finish;
-
-if ($accdata){
if ($accdata->{'amountoutstanding'} < $amountleft) {
$newamtos = 0;
$amountleft -= $accdata->{'amountoutstanding'};
@@ -402,18 +420,24 @@
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
- my $thisacct = $accdata->{accountid};
+ my $thisacct = $accdata->{accountno};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
- where accountid=?");
- $usth->execute($newamtos,$thisacct);
+ where (borrowernumber = ?) and (accountno=?)");
+ $usth->execute($newamtos,$borrowernumber,$thisacct);
$usth->finish;
-
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)");
+ $usth->execute($borrowernumber,$accdata->{'accountno'},$nextaccntno,$newamtos);
+ $usth->finish;
+ }
# begin transaction
+ my $nextaccntno = getnextacctno($env,$borrowernumber,$dbh);
# get lines with outstanding amounts to offset
my $sth = $dbh->prepare("select * from accountlines
where (borrowernumber = ?) and (amountoutstanding >0)
order by date");
- $sth->execute($bornumber);
+ $sth->execute($borrowernumber);
# print $query;
# offset transactions
while (($accdata=$sth->fetchrow_hashref) and ($amountleft>0)){
@@ -424,26 +448,35 @@
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
- my $thisacct = $accdata->{accountid};
+ my $thisacct = $accdata->{accountno};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
- where accountid=?");
- $usth->execute($newamtos,$thisacct);
+ where (borrowernumber = ?) and (accountno=?)");
+ $usth->execute($newamtos,$borrowernumber,$thisacct);
+ $usth->finish;
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)");
+ $usth->execute($borrowernumber,$accdata->{'accountno'},$nextaccntno,$newamtos);
$usth->finish;
- }## while account
+ }
$sth->finish;
-
+ $env->{'branch'}=$user;
+ $type="Credit ".$type;
+ UpdateStats($env,$user,$type,$data,$user,'','',$borrowernumber);
$amountleft*=-1;
- return($amountleft,1,$accdata->{'accountno'});
-}else{
-return("",0);
-}
+ return($amountleft);
+
}
+=head2 refund
+
+# FIXME - Figure out what this function does, and write it down.
+
+=cut
-#
sub refund{
#here we update both the accountoffsets and the account lines
- my ($env,$bornumber,$data)=@_;
+ my ($env,$borrowernumber,$data)=@_;
my $dbh = C4::Context->dbh;
my $newamtos = 0;
my $accdata = "";
@@ -451,11 +484,12 @@
my $amountleft = $data *-1;
# begin transaction
+ my $nextaccntno = getnextacctno($env,$borrowernumber,$dbh);
# get lines with outstanding amounts to offset
my $sth = $dbh->prepare("select * from accountlines
where (borrowernumber = ?) and (amountoutstanding<0)
order by date");
- $sth->execute($bornumber);
+ $sth->execute($borrowernumber);
# print $amountleft;
# offset transactions
while (($accdata=$sth->fetchrow_hashref) and ($amountleft<0)){
@@ -467,127 +501,31 @@
$amountleft = 0;
}
# print $amountleft;
- my $thisacct = $accdata->{accountid};
+ my $thisacct = $accdata->{accountno};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
- where accountid=?");
- $usth->execute($newamtos,$thisacct);
+ where (borrowernumber = ?) and (accountno=?)");
+ $usth->execute($newamtos,$borrowernumber,$thisacct);
+ $usth->finish;
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)");
+ $usth->execute($borrowernumber,$accdata->{'accountno'},$nextaccntno,$newamtos);
$usth->finish;
-
}
$sth->finish;
- return($amountleft*-1);
-}
-
-#Funtion to manage the daily account#
-
-sub dailyAccountBalance {
- my ($date) = @_;
- my $dbh = C4::Context->dbh;
- my $sth;
-
- if ($date) {
-
- $sth = $dbh->prepare("SELECT * FROM dailyaccountbalance WHERE balanceDate = ?");
- $sth->execute($date);
- my $data = $sth->fetchrow_hashref;
- if (!$data->{'balanceDate'}) {
- $data->{'noentry'} = 1;
- }
- return ($data);
-
- } else {
-
- $sth = $dbh->prepare("SELECT * FROM dailyaccountbalance WHERE balanceDate = CURRENT_DATE()");
- $sth->execute();
-
- if ($sth->rows) {
- return ($sth->fetchrow_hashref);
- } else {
- my %hash;
-
- $sth = $dbh->prepare("SELECT currentBalanceInHand FROM dailyaccountbalance ORDER BY balanceDate DESC LIMIT 1");
- $sth->execute();
- if ($sth->rows) {
- ($hash{'initialBalanceInHand'}) = $sth->fetchrow_array;
- $hash{'currentBalanceInHand'} = $hash{'initialBalanceInHand'};
- } else {
- $hash{'initialBalanceInHand'} = 0;
- $hash{'currentBalanceInHand'} = 0;
- }
- #gets the current date.
- my @nowarr = localtime();
- my $date = (1900+$nowarr[5])."-".($nowarr[4]+1)."-".$nowarr[3];
-
- $hash{'balanceDate'} = $date;
- $hash{'initialBalanceInHand'} = sprintf ("%.2f", $hash{'initialBalanceInHand'});
- $hash{'currentBalanceInHand'} = sprintf ("%.2f", $hash{'currentBalanceInHand'});
- return \%hash;
- }
-
- }
+ return($amountleft);
}
-sub addDailyAccountOp {
- my ($description, $amount, $type, $invoice) = @_;
- my $dbh = C4::Context->dbh;
- unless ($invoice) { $invoice = undef};
- my $sth = $dbh->prepare("INSERT INTO dailyaccount (date, description, amount, type, invoice) VALUES (CURRENT_DATE(), ?, ?, ?, ?)");
- $sth->execute($description, $amount, $type, $invoice);
- my $accountop = $dbh->{'mysql_insertid'};
- $sth = $dbh->prepare("SELECT * FROM dailyaccountbalance WHERE balanceDate = CURRENT_DATE()");
- $sth->execute();
- if (!$sth->rows) {
- $sth = $dbh->prepare("SELECT currentBalanceInHand FROM dailyaccountbalance ORDER BY balanceDate DESC LIMIT 1");
- $sth->execute();
- my ($blc) = $sth->fetchrow_array;
- unless ($blc) {$blc = 0}
- $sth = $dbh->prepare("INSERT INTO dailyaccountbalance (balanceDate, initialBalanceInHand, currentBalanceInHand) VALUES (CURRENT_DATE(), ?, ?)");
- $sth->execute($blc, $blc);
- }
- if ($type eq 'D') {
- $amount = -1 * $amount;
- }
- $sth = $dbh->prepare("UPDATE dailyaccountbalance SET currentBalanceInHand = currentBalanceInHand + ? WHERE balanceDate = CURRENT_DATE()");
- $sth->execute($amount);
- return $accountop;
-}
-
-sub getDailyAccountOp {
- my ($date) = @_;
- my $dbh = C4::Context->dbh;
- my $sth;
- if ($date) {
- $sth = $dbh->prepare("SELECT * FROM dailyaccount WHERE date = ?");
- $sth->execute($date);
- } else {
- $sth = $dbh->prepare("SELECT * FROM dailyaccount WHERE date = CURRENT_DATE()");
- $sth->execute();
- }
- my @operations;
- my $count = 1;
- while (my $row = $sth->fetchrow_hashref) {
- $row->{'num'} = $count++;
- $row->{$row->{'type'}} = 1;
-
- $row->{'invoice'} =~ /(\w*)\-(\w*)\-(\w*)/;
- $row->{'invoiceNumber'} = $1;
- $row->{'invoiceSupplier'} = $2;
- $row->{'invoiceType'} = $3;
-
- push @operations, $row;
- }
- return (scalar(@operations), \@operations);
-}
END { } # module clean-up code here (global destructor)
1;
__END__
-=back
=head1 SEE ALSO
DBI(3)
=cut
+
Index: Acquisition.pm
===================================================================
RCS file: /sources/koha/koha/C4/Acquisition.pm,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -b -r1.48 -r1.49
--- Acquisition.pm 13 Dec 2006 20:02:34 -0000 1.48
+++ Acquisition.pm 9 Mar 2007 14:31:47 -0000 1.49
@@ -17,20 +17,20 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Acquisition.pm,v 1.48 2006/12/13 20:02:34 bob_lyon Exp $
+# $Id: Acquisition.pm,v 1.49 2007/03/09 14:31:47 tipaul Exp $
use strict;
require Exporter;
use C4::Context;
use C4::Date;
+use MARC::Record;
use C4::Suggestions;
-use C4::Biblio;
use Time::localtime;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.48 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+$VERSION = do { my @v = '$Revision: 1.49 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
# used in receiveorder subroutine
# to provide library specific handling
@@ -60,13 +60,11 @@
&GetBasket &NewBasket &CloseBasket
&GetPendingOrders &GetOrder &GetOrders
&GetOrderNumber &GetLateOrders &NewOrder &DelOrder
- &GetHistory
- &ModOrder &ModReceiveOrder
- &GetSingleOrder
- &bookseller
+ &SearchOrder &GetHistory &GetRecentAcqui
+ &ModOrder &ModReceiveOrder &ModOrderBiblioNumber
+ &GetParcels &GetParcel
);
-
=head2 FUNCTIONS ABOUT BASKETS
=over 2
@@ -93,11 +91,11 @@
=cut
sub GetBasket {
- my ($basketno) = shift;
+ my ($basketno) = @_;
my $dbh = C4::Context->dbh;
my $query = "
SELECT aqbasket.*,
- concat(borrowers.firstname,' ',borrowers.surname) AS authorisedbyname,
+ borrowers.firstname+' '+borrowers.surname AS authorisedbyname,
borrowers.branchcode AS branch
FROM aqbasket
LEFT JOIN borrowers ON aqbasket.authorisedby=borrowers.borrowernumber
@@ -182,13 +180,15 @@
=over 4
-$orders = &GetPendingOrders($booksellerid);
+$orders = &GetPendingOrders($booksellerid, $grouped);
Finds pending orders from the bookseller with the given ID. Ignores
completed and cancelled orders.
C<$orders> is a reference-to-array; each element is a
reference-to-hash with the following fields:
+C<$grouped> is a boolean that, if set to 1 will group all order lines of the same basket
+in a single result line
=over 2
@@ -210,17 +210,21 @@
=cut
sub GetPendingOrders {
- my $supplierid = shift;
+ my ($supplierid,$grouped) = @_;
my $dbh = C4::Context->dbh;
- my $strsth = "SELECT aqorders.*,aqbasket.*,borrowers.firstname,borrowers.surname
+ my $strsth = "
+ SELECT ".($grouped?"count(*),":"")."aqbasket.basketno,
+ surname,firstname,aqorders.*,
+ aqbasket.closedate, aqbasket.creationdate
FROM aqorders
LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
LEFT JOIN borrowers ON aqbasket.authorisedby=borrowers.borrowernumber
WHERE booksellerid=?
AND (quantity > quantityreceived OR quantityreceived is NULL)
AND datecancellationprinted IS NULL
- AND (to_days(now())-to_days(closedate) < 180 OR closedate IS NULL) ";
-
+ AND (to_days(now())-to_days(closedate) < 180 OR closedate IS NULL)
+ ";
+ ## FIXME Why 180 days ???
if ( C4::Context->preference("IndependantBranches") ) {
my $userenv = C4::Context->userenv;
if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
@@ -230,15 +234,14 @@
. "' or borrowers.branchcode ='')";
}
}
- $strsth .= " group by aqbasket.basketno order by aqbasket.basketno";
+ $strsth .= " group by aqbasket.basketno" if $grouped;
+ $strsth .= " order by aqbasket.basketno";
+
my $sth = $dbh->prepare($strsth);
$sth->execute($supplierid);
- my @results;
- while (my $data = $sth->fetchrow_hashref ) {
- push @results, $data ;
- }
+ my $results = $sth->fetchall_arrayref({});
$sth->finish;
- return \@results;
+ return $results;
}
#------------------------------------------------------------#
@@ -249,7 +252,7 @@
@orders = &GetOrders($basketnumber, $orderby);
-Looks up the non-cancelled orders (whether received or not) with the given basket
+Looks up the pending (non-cancelled) orders with the given basket
number. If C<$booksellerID> is non-empty, only orders from that seller
are returned.
@@ -267,23 +270,25 @@
my $dbh = C4::Context->dbh;
my $query ="
SELECT aqorderbreakdown.*,
- biblio.*,
- aqorders.*
- FROM aqorders,biblio
- LEFT JOIN aqorderbreakdown ON
- aqorders.ordernumber=aqorderbreakdown.ordernumber
+ biblio.*,biblioitems.*,
+ aqorders.*,
+ aqbookfund.bookfundname,
+ biblio.title
+ FROM aqorders
+ LEFT JOIN aqorderbreakdown ON aqorders.ordernumber=aqorderbreakdown.ordernumber
+ LEFT JOIN biblio ON biblio.biblionumber=aqorders.biblionumber
+ LEFT JOIN biblioitems ON biblioitems.biblioitemnumber=aqorders.biblioitemnumber
+ LEFT JOIN aqbookfund ON aqbookfund.bookfundid=aqorderbreakdown.bookfundid
WHERE basketno=?
- AND biblio.biblionumber=aqorders.biblionumber
AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')
";
- $orderby = "biblio.title" unless $orderby;
+ $orderby = "biblioitems.publishercode" unless $orderby;
$query .= " ORDER BY $orderby";
my $sth = $dbh->prepare($query);
$sth->execute($basketno);
my @results;
- # print $query;
while ( my $data = $sth->fetchrow_hashref ) {
push @results, $data;
}
@@ -291,19 +296,6 @@
return @results;
}
-sub GetSingleOrder {
- my ($ordnum)=@_;
- my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select * from biblio,aqorders left join aqorderbreakdown
- on aqorders.ordernumber=aqorderbreakdown.ordernumber
- where aqorders.ordernumber=?
- and biblio.biblionumber=aqorders.biblionumber");
- $sth->execute($ordnum);
- my $data=$sth->fetchrow_hashref;
- $sth->finish;
- return($data);
-}
-
#------------------------------------------------------------#
=head3 GetOrderNumber
@@ -312,7 +304,7 @@
$ordernumber = &GetOrderNumber($biblioitemnumber, $biblionumber);
-Looks up the ordernumber with the given biblionumber
+Looks up the ordernumber with the given biblionumber and biblioitemnumber.
Returns the number of this order.
@@ -322,16 +314,16 @@
=cut
sub GetOrderNumber {
- my ( $biblionumber ) = @_;
+ my ( $biblionumber,$biblioitemnumber ) = @_;
my $dbh = C4::Context->dbh;
my $query = "
SELECT ordernumber
FROM aqorders
WHERE biblionumber=?
-
+ AND biblioitemnumber=?
";
my $sth = $dbh->prepare($query);
- $sth->execute( $biblionumber );
+ $sth->execute( $biblionumber, $biblioitemnumber );
return $sth->fetchrow;
}
@@ -347,7 +339,7 @@
Looks up an order by order number.
Returns a reference-to-hash describing the order. The keys of
-C<$order> are fields from the biblio, , aqorders, and
+C<$order> are fields from the biblio, biblioitems, aqorders, and
aqorderbreakdown tables of the Koha database.
=back
@@ -359,10 +351,11 @@
my $dbh = C4::Context->dbh;
my $query = "
SELECT *
- FROM biblio,aqorders
+ FROM aqorders
LEFT JOIN aqorderbreakdown ON aqorders.ordernumber=aqorderbreakdown.ordernumber
+ LEFT JOIN biblio on biblio.biblionumber=aqorders.biblionumber
+ LEFT JOIN biblioitems on biblioitems.biblionumber=aqorders.biblionumber
WHERE aqorders.ordernumber=?
- AND biblio.biblionumber=aqorders.biblionumber
";
my $sth= $dbh->prepare($query);
@@ -403,11 +396,11 @@
sub NewOrder {
my (
- $basketno, $biblionumber, $title, $quantity,
+ $basketno, $bibnum, $title, $quantity,
$listprice, $booksellerid, $authorisedby, $notes,
- $bookfund, $rrp, $ecost,
+ $bookfund, $bibitemnum, $rrp, $ecost,
$gst, $budget, $cost, $sub,
- $purchaseorderno, $sort1, $sort2,$discount,$branch
+ $invoice, $sort1, $sort2
)
= @_;
@@ -418,6 +411,17 @@
$budget = "now()";
}
+ # if month is july or more, budget start is 1 jul, next year.
+ elsif ( $month >= '7' ) {
+ ++$year; # add 1 to year , coz its next year
+ $budget = "'$year-07-01'";
+ }
+ else {
+
+ # START OF NEW BUDGET, 1ST OF JULY, THIS YEAR
+ $budget = "'$year-07-01'";
+ }
+
if ( $sub eq 'yes' ) {
$sub = 1;
}
@@ -434,26 +438,26 @@
my $query = "
INSERT INTO aqorders
( biblionumber,title,basketno,quantity,listprice,notes,
- rrp,ecost,gst,unitprice,subscription,sort1,sort2,purchaseordernumber,discount,budgetdate,entrydate)
- VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,$budget,now() )
+ biblioitemnumber,rrp,ecost,gst,unitprice,subscription,sort1,sort2,budgetdate,entrydate)
+ VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,$budget,now() )
";
my $sth = $dbh->prepare($query);
$sth->execute(
- $biblionumber, $title, $basketno, $quantity, $listprice,
- $notes, $rrp, $ecost, $gst,
- $cost, $sub, $sort1, $sort2,$purchaseorderno,$discount
+ $bibnum, $title, $basketno, $quantity, $listprice,
+ $notes, $bibitemnum, $rrp, $ecost, $gst,
+ $cost, $sub, $sort1, $sort2
);
$sth->finish;
#get ordnum MYSQL dependant, but $dbh->last_insert_id returns null
my $ordnum = $dbh->{'mysql_insertid'};
- my $query = "
- INSERT INTO aqorderbreakdown (ordernumber,bookfundid,branchcode)
- VALUES (?,?,?)
+ $query = "
+ INSERT INTO aqorderbreakdown (ordernumber,bookfundid)
+ VALUES (?,?)
";
$sth = $dbh->prepare($query);
- $sth->execute( $ordnum, $bookfund,$branch );
+ $sth->execute( $ordnum, $bookfund );
$sth->finish;
return ( $basketno, $ordnum );
}
@@ -483,10 +487,10 @@
sub ModOrder {
my (
- $title, $ordnum, $quantity, $listprice, $biblionumber,
+ $title, $ordnum, $quantity, $listprice, $bibnum,
$basketno, $supplier, $who, $notes, $bookfund,
- $rrp, $ecost, $gst, $budget,
- $cost, $invoice, $sort1, $sort2,$discount,$branch
+ $bibitemnum, $rrp, $ecost, $gst, $budget,
+ $cost, $invoice, $sort1, $sort2
)
= @_;
my $dbh = C4::Context->dbh;
@@ -494,32 +498,63 @@
UPDATE aqorders
SET title=?,
quantity=?,listprice=?,basketno=?,
- rrp=?,ecost=?,unitprice=?,purchaseordernumber=?,gst=?,
- notes=?,sort1=?, sort2=?,discount=?
+ rrp=?,ecost=?,unitprice=?,booksellerinvoicenumber=?,
+ notes=?,sort1=?, sort2=?
WHERE ordernumber=? AND biblionumber=?
";
my $sth = $dbh->prepare($query);
$sth->execute(
$title, $quantity, $listprice, $basketno, $rrp,
- $ecost, $cost, $invoice, $gst, $notes, $sort1,
- $sort2, $discount,$ordnum, $biblionumber
+ $ecost, $cost, $invoice, $notes, $sort1,
+ $sort2, $ordnum, $bibnum
);
$sth->finish;
- my $query = "
- REPLACE aqorderbreakdown
- SET ordernumber=?, bookfundid=?, branchcode=?
+ $query = "
+ UPDATE aqorderbreakdown
+ SET bookfundid=?
+ WHERE ordernumber=?
";
$sth = $dbh->prepare($query);
- $sth->execute( $ordnum,$bookfund, $branch );
-
+ unless ( $sth->execute( $bookfund, $ordnum ) )
+ { # zero rows affected [Bug 734]
+ my $query ="
+ INSERT INTO aqorderbreakdown
+ (ordernumber,bookfundid)
+ VALUES (?,?)
+ ";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $ordnum, $bookfund );
+ }
$sth->finish;
}
#------------------------------------------------------------#
+=head3 ModOrderBiblioNumber
+
+=over 4
+
+&ModOrderBiblioNumber($biblioitemnumber,$ordnum, $biblionumber);
+
+Modifies the biblioitemnumber for an existing order.
+Updates the order with order number C<$ordernum> and biblionumber C<$biblionumber>.
+
+=back
+=cut
+sub ModOrderBiblioNumber {
+ my ($biblioitemnumber,$ordnum, $biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqorders
+ SET biblioitemnumber = ?
+ WHERE ordernumber = ?
+ AND biblionumber = ?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblioitemnumber, $ordnum, $biblionumber );
+}
#------------------------------------------------------------#
@@ -538,6 +573,7 @@
Updates the order with bibilionumber C<$biblionumber> and ordernumber
C<$ordernumber>.
+Also updates the book fund ID in the aqorderbreakdown table.
=back
@@ -546,28 +582,160 @@
sub ModReceiveOrder {
my (
- $biblionumber, $ordnum, $quantrec, $cost,
- $invoiceno, $freight, $rrp, $listprice,$input
+ $biblionumber, $ordnum, $quantrec, $user, $cost,
+ $invoiceno, $freight, $rrp, $bookfund, $daterecieved
)
= @_;
my $dbh = C4::Context->dbh;
+# warn "DATE BEFORE : $daterecieved";
+ $daterecieved=POSIX::strftime("%Y-%m-%d",CORE::localtime) unless $daterecieved;
+# warn "DATE REC : $daterecieved";
my $query = "
UPDATE aqorders
- SET quantityreceived=quantityreceived+?,datereceived=now(),booksellerinvoicenumber=?,
- unitprice=?,freight=?,rrp=?,listprice=?
+ SET quantityreceived=?,datereceived=?,booksellerinvoicenumber=?,
+ unitprice=?,freight=?,rrp=?
WHERE biblionumber=? AND ordernumber=?
";
my $sth = $dbh->prepare($query);
my $suggestionid = GetSuggestionFromBiblionumber( $dbh, $biblionumber );
if ($suggestionid) {
- ModStatus( $suggestionid, 'AVAILABLE', '', $biblionumber,$input );
+ ModStatus( $suggestionid, 'AVAILABLE', '', $biblionumber );
}
- $sth->execute( $quantrec, $invoiceno, $cost, $freight, $rrp, $listprice, $biblionumber,
- $ordnum );
+ $sth->execute( $quantrec,$daterecieved, $invoiceno, $cost, $freight, $rrp, $biblionumber,
+ $ordnum);
$sth->finish;
+ # Allows libraries to change their bookfund during receiving orders
+ # allows them to adjust budgets
+ if ( C4::Context->preferene("LooseBudgets") ) {
+ my $query = "
+ UPDATE aqorderbreakdown
+ SET bookfundid=?
+ WHERE ordernumber=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $bookfund, $ordnum );
+ $sth->finish;
+ }
+ return $daterecieved;
}
+#------------------------------------------------------------#
+
+=head3 SearchOrder
+
+ at results = &SearchOrder($search, $biblionumber, $complete);
+
+Searches for orders.
+
+C<$search> may take one of several forms: if it is an ISBN,
+C<&ordersearch> returns orders with that ISBN. If C<$search> is an
+order number, C<&ordersearch> returns orders with that order number
+and biblionumber C<$biblionumber>. Otherwise, C<$search> is considered
+to be a space-separated list of search terms; in this case, all of the
+terms must appear in the title (matching the beginning of title
+words).
+
+If C<$complete> is C<yes>, the results will include only completed
+orders. In any case, C<&ordersearch> ignores cancelled orders.
+
+C<&ordersearch> returns an array.
+C<@results> is an array of references-to-hash with the following keys:
+
+=over 4
+
+=item C<author>
+
+=item C<seriestitle>
+
+=item C<branchcode>
+
+=item C<bookfundid>
+
+=back
+
+=cut
+
+sub SearchOrder {
+ my ( $search, $id, $biblionumber, $catview ) = @_;
+ my $dbh = C4::Context->dbh;
+ my @data = split( ' ', $search );
+ my @searchterms;
+ if ($id) {
+ @searchterms = ($id);
+ }
+ map { push( @searchterms, "$_%", "% $_%" ) } @data;
+ push( @searchterms, $search, $search, $biblionumber );
+ my $query;
+ if ($id) {
+ $query =
+ "SELECT *,biblio.title FROM aqorders,biblioitems,biblio,aqbasket
+ WHERE aqorders.biblioitemnumber = biblioitems.biblioitemnumber AND
+ aqorders.basketno = aqbasket.basketno
+ AND aqbasket.booksellerid = ?
+ AND biblio.biblionumber=aqorders.biblionumber
+ AND ((datecancellationprinted is NULL)
+ OR (datecancellationprinted = '0000-00-00'))
+ AND (("
+ . (
+ join( " AND ",
+ map { "(biblio.title like ? or biblio.title like ?)" } @data )
+ )
+ . ") OR biblioitems.isbn=? OR (aqorders.ordernumber=? AND aqorders.biblionumber=?)) ";
+
+ }
+ else {
+ $query =
+ " SELECT *,biblio.title
+ FROM aqorders,biblioitems,biblio,aqbasket
+ WHERE aqorders.biblioitemnumber = biblioitems.biblioitemnumber
+ AND aqorders.basketno = aqbasket.basketno
+ AND biblio.biblionumber=aqorders.biblionumber
+ AND ((datecancellationprinted is NULL)
+ OR (datecancellationprinted = '0000-00-00'))
+ AND (aqorders.quantityreceived < aqorders.quantity OR aqorders.quantityreceived is NULL)
+ AND (("
+ . (
+ join( " AND ",
+ map { "(biblio.title like ? OR biblio.title like ?)" } @data )
+ )
+ . ") or biblioitems.isbn=? OR (aqorders.ordernumber=? AND aqorders.biblionumber=?)) ";
+ }
+ $query .= " GROUP BY aqorders.ordernumber";
+ ### $query
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@searchterms);
+ my @results = ();
+ my $query2 = "
+ SELECT *
+ FROM biblio
+ WHERE biblionumber=?
+ ";
+ my $sth2 = $dbh->prepare($query2);
+ my $query3 = "
+ SELECT *
+ FROM aqorderbreakdown
+ WHERE ordernumber=?
+ ";
+ my $sth3 = $dbh->prepare($query3);
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $sth2->execute( $data->{'biblionumber'} );
+ my $data2 = $sth2->fetchrow_hashref;
+ $data->{'author'} = $data2->{'author'};
+ $data->{'seriestitle'} = $data2->{'seriestitle'};
+ $sth3->execute( $data->{'ordernumber'} );
+ my $data3 = $sth3->fetchrow_hashref;
+ $data->{'branchcode'} = $data3->{'branchcode'};
+ $data->{'bookfundid'} = $data3->{'bookfundid'};
+ push( @results, $data );
+ }
+ ### @results
+ $sth->finish;
+ $sth2->finish;
+ $sth3->finish;
+ return @results;
+}
#------------------------------------------------------------#
@@ -586,15 +754,15 @@
=cut
sub DelOrder {
- my ( $biblionumber, $ordnum,$user ) = @_;
+ my ( $bibnum, $ordnum ) = @_;
my $dbh = C4::Context->dbh;
my $query = "
UPDATE aqorders
- SET datecancellationprinted=now(), cancelledby=?
+ SET datecancellationprinted=now()
WHERE biblionumber=? AND ordernumber=?
";
my $sth = $dbh->prepare($query);
- $sth->execute( $user,$biblionumber, $ordnum );
+ $sth->execute( $bibnum, $ordnum );
$sth->finish;
}
@@ -621,28 +789,28 @@
bookseller ID at the given date, for the given code (bookseller Invoice number). Ignores cancelled and completed orders.
C<@results> is an array of references-to-hash. The keys of each element are fields from
-the aqorders, biblio tables of the Koha database.
+the aqorders, biblio, and biblioitems tables of the Koha database.
C<@results> is sorted alphabetically by book title.
=back
=cut
-## This routine is not used will be cleaned
-sub GetParcel {
+sub GetParcel {
#gets all orders from a certain supplier, orders them alphabetically
- my ( $supplierid, $invoice, $datereceived ) = @_;
+ my ( $supplierid, $code, $datereceived ) = @_;
my $dbh = C4::Context->dbh;
my @results = ();
- $invoice .= '%' if $invoice; # add % if we search on a given invoice
+ $code .= '%'
+ if $code; # add % if we search on a given code (otherwise, let him empty)
my $strsth ="
SELECT authorisedby,
creationdate,
aqbasket.basketno,
closedate,surname,
firstname,
- biblionumber,
+ aqorders.biblionumber,
aqorders.title,
aqorders.ordernumber,
aqorders.quantity,
@@ -655,8 +823,8 @@
LEFT JOIN borrowers ON aqbasket.authorisedby=borrowers.borrowernumber
WHERE aqbasket.basketno=aqorders.basketno
AND aqbasket.booksellerid=?
- AND (aqorders.datereceived= \"$datereceived\" OR aqorders.datereceived is NULL)";
- $strsth.= " AND aqorders.purchaseordernumber LIKE \"$invoice\"" if $invoice ne "%";
+ AND aqorders.booksellerinvoicenumber LIKE \"$code\"
+ AND aqorders.datereceived= \'$datereceived\'";
if ( C4::Context->preference("IndependantBranches") ) {
my $userenv = C4::Context->userenv;
@@ -672,9 +840,9 @@
my $sth = $dbh->prepare($strsth);
$sth->execute($supplierid);
while ( my $data = $sth->fetchrow_hashref ) {
- push @results, $data ;
+ push( @results, $data );
}
- ### countparcelbiblio: $count
+ ### countparcelbiblio: scalar(@results)
$sth->finish;
return @results;
@@ -717,7 +885,7 @@
=back
=cut
-### This routine is not used will be cleaned
+
sub GetParcels {
my ($bookseller,$order, $code, $datefrom, $dateto) = @_;
my $dbh = C4::Context->dbh;
@@ -740,17 +908,13 @@
$strsth .= "group by aqorders.booksellerinvoicenumber,datereceived ";
$strsth .= "order by $order " if ($order);
+### $strsth
my $sth = $dbh->prepare($strsth);
$sth->execute;
- my @results;
-
- while ( my $data2 = $sth->fetchrow_hashref ) {
- push @results, $data2;
- }
-
+ my $results = $sth->fetchall_arrayref({});
$sth->finish;
- return @results;
+ return @$results;
}
#------------------------------------------------------------#
@@ -771,7 +935,6 @@
=cut
sub GetLateOrders {
-## requirse fixing for KOHA 3 API. Currently does not return publisher
my $delay = shift;
my $supplierid = shift;
my $branch = shift;
@@ -785,7 +948,7 @@
# warn " $dbdriver";
if ( $dbdriver eq "mysql" ) {
$strsth = "
- SELECT aqbasket.basketno,
+ SELECT aqbasket.basketno,aqorders.ordernumber,
DATE(aqbasket.closedate) AS orderdate,
aqorders.quantity - IFNULL(aqorders.quantityreceived,0) AS quantity,
aqorders.rrp AS unitpricesupplier,
@@ -796,11 +959,12 @@
aqbooksellers.name AS supplier,
aqorders.title,
biblio.author,
-
+ biblioitems.publishercode AS publisher,
+ biblioitems.publicationyear,
DATEDIFF(CURDATE( ),closedate) AS latesince
- FROM ((
+ FROM (((
(aqorders LEFT JOIN biblio ON biblio.biblionumber = aqorders.biblionumber)
-
+ LEFT JOIN biblioitems ON biblioitems.biblionumber=biblio.biblionumber)
LEFT JOIN aqorderbreakdown ON aqorders.ordernumber = aqorderbreakdown.ordernumber)
LEFT JOIN aqbookfund ON aqorderbreakdown.bookfundid = aqbookfund.bookfundid),
(aqbasket LEFT JOIN borrowers ON aqbasket.authorisedby = borrowers.borrowernumber)
@@ -837,11 +1001,12 @@
aqbooksellers.name AS supplier,
biblio.title,
biblio.author,
-
+ biblioitems.publishercode AS publisher,
+ biblioitems.publicationyear,
(CURDATE - closedate) AS latesince
- FROM((
+ FROM(( (
(aqorders LEFT JOIN biblio on biblio.biblionumber = aqorders.biblionumber)
-
+ LEFT JOIN biblioitems on biblioitems.biblionumber=biblio.biblionumber)
LEFT JOIN aqorderbreakdown on aqorders.ordernumber = aqorderbreakdown.ordernumber)
LEFT JOIN aqbookfund ON aqorderbreakdown.bookfundid = aqbookfund.bookfundid),
(aqbasket LEFT JOIN borrowers on aqbasket.authorisedby = borrowers.borrowernumber) LEFT JOIN aqbooksellers ON aqbasket.booksellerid = aqbooksellers.id
@@ -904,7 +1069,9 @@
aqorders.quantity,
aqorders.quantityreceived,
aqorders.ecost,
- aqorders.ordernumber
+ aqorders.ordernumber,
+ aqorders.booksellerinvoicenumber as invoicenumber,
+ aqbooksellers.id as id
FROM aqorders,aqbasket,aqbooksellers,biblio";
$query .= ",borrowers "
@@ -960,37 +1127,30 @@
return \@order_loop, $total_qty, $total_price, $total_qtyreceived;
}
-#------------------------------------------------------------#
-
-=head3 bookseller
+=head2 GetRecentAcqui
-=over 4
-
-($count, @results) = &bookseller($searchstring);
-
-Looks up a book seller. C<$searchstring> may be either a book seller
-ID, or a string to look for in the book seller's name.
-
-C<$count> is the number of elements in C<@results>. C<@results> is an
-array of references-to-hash, whose keys are the fields of of the
-aqbooksellers table in the Koha database.
+ $results = GetRecentAcqui($days);
-=back
+ C<$results> is a ref to a table which containts hashref
=cut
-sub bookseller {
- my ($searchstring) = @_;
+sub GetRecentAcqui {
+ my $limit = shift;
my $dbh = C4::Context->dbh;
- my $sth =
- $dbh->prepare("Select * from aqbooksellers where name like ? or id = ?");
- $sth->execute( "$searchstring%", $searchstring );
+ my $query = "
+ SELECT *
+ FROM biblio
+ ORDER BY timestamp DESC
+ LIMIT 0,".$limit;
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
my @results;
- while ( my $data = $sth->fetchrow_hashref ) {
- push( @results, $data );
+ while(my $data = $sth->fetchrow_hashref){
+ push @results,$data;
}
- $sth->finish;
- return ( scalar(@results), @results );
+ return \@results;
}
END { } # module clean-up code here (global destructor)
Index: Amazon.pm
===================================================================
RCS file: /sources/koha/koha/C4/Amazon.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- Amazon.pm 25 Aug 2006 21:07:08 -0000 1.5
+++ Amazon.pm 9 Mar 2007 14:31:47 -0000 1.6
@@ -34,12 +34,23 @@
# loop SimilarProducts (Product)
# loop Reviews (rating, Summary)
#
+use XML::Simple;
+use LWP::Simple;
use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = 0.01;
+$VERSION = 0.02;
+=head1 NAME
+
+C4::Amazon - Functions for retrieving Amazon.com content in Koha
+
+=head1 FUNCTIONS
+
+This module provides facilities for retrieving Amazon.com content in Koha
+
+=cut
@ISA = qw(Exporter);
@@ -47,15 +58,24 @@
&get_amazon_details
);
+=head1 get_amazon_details($isbn);
+
+=head2 $isbn is a isbn string
+
+=cut
+
sub get_amazon_details {
my ( $isbn ) = @_;
# insert your dev key here
-my $dev_key='neulibrary-20';
-$isbn=substr($isbn,0,9);
+ $isbn =~ s/(p|-)//g;
+
# insert your associates tag here
-my $af_tag='0YGCZ5GV9ZNGGS7THDG2';
+ my $dev_key=C4::Context->preference('AmazonDevKey');
+
+ #grab the associates tag: mine is '0ZRY7YASKJS280T7YB02'
+ my $af_tag=C4::Context->preference('AmazonAssocTag');
my $asin=$isbn;
@@ -65,27 +85,19 @@
# "&dev-t=" . $dev_key .
# "&type=heavy&f=xml&" .
# "AsinSearch=" . $asin;
-my $url = "http://xml.amazon.com/onca/xml3?t=$dev_key&dev-t=$af_tag&type=heavy&f=xml&AsinSearch=" . $asin;
-
-#Here's an example asin for the book "Cryptonomicon"
-#0596005423";
-
-use XML::Simple;
-use LWP::Simple;
+ my $url = "http://xml.amazon.com/onca/xml3?t=$af_tag&dev-t=$dev_key&type=heavy&f=xml&AsinSearch=" . $asin;
my $content = get($url);
-if ($content){
-
+ warn "could not retrieve $url" unless $content;
my $xmlsimple = XML::Simple->new();
my $response = $xmlsimple->XMLin($content,
- forcearray => [ qw(Details Product AvgCustomerRating CustomerReview ) ],
+ forcearray => [ qw(Details Product AvgCustomerRating CustomerReview) ],
);
return $response;
-#foreach my $result (@{$response->{Details}}){
-# my $product_description = $result->{ProductDescription};
-# my $image = $result->{ImageUrlMedium};
-# my $price = $result->{ListPrice};
-# my $reviews = $result->{
-# return $result;
-#}
-}
}
\ No newline at end of file
+
+=head1 NOTES
+
+=head1 AUTHOR
+
+Joshua Ferraro <jmf at liblime.com>
+=cut
Index: Auth.pm
===================================================================
RCS file: /sources/koha/koha/C4/Auth.pm,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -b -r1.57 -r1.58
--- Auth.pm 6 Nov 2006 21:01:43 -0000 1.57
+++ Auth.pm 9 Mar 2007 14:31:47 -0000 1.58
@@ -27,20 +27,20 @@
use C4::Context;
use C4::Output; # to get the template
use C4::Interface::CGI::Output;
-use C4::Members; # getpatroninformation
-use C4::Koha;## to get branch
+use C4::Circulation::Circ2; # getpatroninformation
+use C4::Koha;
+use C4::Branch; # GetBranches
+
# use Net::LDAP;
# use Net::LDAP qw(:all);
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
-$VERSION = 0.01;
- at ISA = qw(Exporter);
+$VERSION = do { my @v = '$Revision: 1.58 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
- at EXPORT = qw(
-&checkpw
-);
=head1 NAME
C4::Auth - Authenticates Koha users
@@ -61,8 +61,7 @@
});
print $query->header(
- -type => "text/html",
- -charset=>"utf-8",
+ -type => guesstype($template->output),
-cookie => $cookie
), $template->output;
@@ -80,8 +79,6 @@
=cut
-
-
@ISA = qw(Exporter);
@EXPORT = qw(
&checkauth
@@ -114,130 +111,166 @@
=cut
-
sub get_template_and_user {
my $in = shift;
- my $template = gettemplate($in->{'template_name'}, $in->{'type'},$in->{'query'});
- my ($user, $cookie, $sessionID, $flags)
- = checkauth($in->{'query'}, $in->{'authnotrequired'}, $in->{'flagsrequired'}, $in->{'type'});
+ my $template =
+ gettemplate( $in->{'template_name'}, $in->{'type'}, $in->{'query'} );
+ my ( $user, $cookie, $sessionID, $flags ) = checkauth(
+ $in->{'query'},
+ $in->{'authnotrequired'},
+ $in->{'flagsrequired'},
+ $in->{'type'}
+ );
my $borrowernumber;
- if ($user) {
- $template->param(loggedinusername => $user);
- $template->param(sessionID => $sessionID);
+ my $insecure = C4::Context->preference('insecure');
+ if ($user or $insecure) {
+ $template->param( loggedinusername => $user );
+ $template->param( sessionID => $sessionID );
$borrowernumber = getborrowernumber($user);
- my ($borr, $alternativeflags) = getpatroninformation(undef, $borrowernumber);
+ my ( $borr, $alternativeflags ) =
+ getpatroninformation( undef, $borrowernumber );
my @bordat;
$bordat[0] = $borr;
- $template->param(USER_INFO => \@bordat,
- );
- my $branches=GetBranches();
- $template->param(branchname=>$branches->{$borr->{branchcode}}->{branchname},);
+ $template->param( "USER_INFO" => \@bordat );
# We are going to use the $flags returned by checkauth
# to create the template's parameters that will indicate
# which menus the user can access.
- if ($flags && $flags->{superlibrarian} == 1)
- {
- $template->param(CAN_user_circulate => 1);
- $template->param(CAN_user_catalogue => 1);
- $template->param(CAN_user_parameters => 1);
- $template->param(CAN_user_borrowers => 1);
- $template->param(CAN_user_permission => 1);
- $template->param(CAN_user_reserveforothers => 1);
- $template->param(CAN_user_borrow => 1);
- $template->param(CAN_user_reserveforself => 1);
- $template->param(CAN_user_editcatalogue => 1);
- $template->param(CAN_user_updatecharge => 1);
- $template->param(CAN_user_acquisition => 1);
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
-
- if ($flags && $flags->{circulate} == 1) {
- $template->param(CAN_user_circulate => 1); }
-
- if ($flags && $flags->{catalogue} == 1) {
- $template->param(CAN_user_catalogue => 1); }
-
-
- if ($flags && $flags->{parameters} == 1) {
- $template->param(CAN_user_parameters => 1);
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
-
-
- if ($flags && $flags->{borrowers} == 1) {
- $template->param(CAN_user_borrowers => 1); }
-
+ if (( $flags && $flags->{superlibrarian}==1) or $insecure==1) {
+ $template->param( CAN_user_circulate => 1 );
+ $template->param( CAN_user_catalogue => 1 );
+ $template->param( CAN_user_parameters => 1 );
+ $template->param( CAN_user_borrowers => 1 );
+ $template->param( CAN_user_permission => 1 );
+ $template->param( CAN_user_reserveforothers => 1 );
+ $template->param( CAN_user_borrow => 1 );
+ $template->param( CAN_user_editcatalogue => 1 );
+ $template->param( CAN_user_updatecharge => 1 );
+ $template->param( CAN_user_acquisition => 1 );
+ $template->param( CAN_user_management => 1 );
+ $template->param( CAN_user_tools => 1 );
+ $template->param( CAN_user_editauthorities => 1 );
+ $template->param( CAN_user_serials => 1 );
+ $template->param( CAN_user_reports => 1 );
+ }
- if ($flags && $flags->{permissions} == 1) {
- $template->param(CAN_user_permission => 1); }
+ if ( $flags && $flags->{circulate} == 1 ) {
+ $template->param( CAN_user_circulate => 1 );
+ }
- if ($flags && $flags->{reserveforothers} == 1) {
- $template->param(CAN_user_reserveforothers => 1); }
+ if ( $flags && $flags->{catalogue} == 1 ) {
+ $template->param( CAN_user_catalogue => 1 );
+ }
+ if ( $flags && $flags->{parameters} == 1 ) {
+ $template->param( CAN_user_parameters => 1 );
+ $template->param( CAN_user_management => 1 );
+ }
- if ($flags && $flags->{borrow} == 1) {
- $template->param(CAN_user_borrow => 1); }
+ if ( $flags && $flags->{borrowers} == 1 ) {
+ $template->param( CAN_user_borrowers => 1 );
+ }
+ if ( $flags && $flags->{permissions} == 1 ) {
+ $template->param( CAN_user_permission => 1 );
+ }
- if ($flags && $flags->{reserveforself} == 1) {
- $template->param(CAN_user_reserveforself => 1); }
+ if ( $flags && $flags->{reserveforothers} == 1 ) {
+ $template->param( CAN_user_reserveforothers => 1 );
+ }
+ if ( $flags && $flags->{borrow} == 1 ) {
+ $template->param( CAN_user_borrow => 1 );
+ }
- if ($flags && $flags->{editcatalogue} == 1) {
- $template->param(CAN_user_editcatalogue => 1); }
+ if ( $flags && $flags->{editcatalogue} == 1 ) {
+ $template->param( CAN_user_editcatalogue => 1 );
+ }
+ if ( $flags && $flags->{updatecharges} == 1 ) {
+ $template->param( CAN_user_updatecharge => 1 );
+ }
- if ($flags && $flags->{updatecharges} == 1) {
- $template->param(CAN_user_updatecharge => 1); }
+ if ( $flags && $flags->{acquisition} == 1 ) {
+ $template->param( CAN_user_acquisition => 1 );
+ }
- if ($flags && $flags->{acquisition} == 1) {
- $template->param(CAN_user_acquisition => 1); }
+ if ( $flags && $flags->{tools} == 1 ) {
+ $template->param( CAN_user_tools => 1 );
+ }
- if ($flags && $flags->{management} == 1) {
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
+ if ( $flags && $flags->{editauthorities} == 1 ) {
+ $template->param( CAN_user_editauthorities => 1 );
+ }
- if ($flags && $flags->{tools} == 1) {
- $template->param(CAN_user_tools => 1); }
+ if ( $flags && $flags->{serials} == 1 ) {
+ $template->param( CAN_user_serials => 1 );
+ }
+ if ( $flags && $flags->{reports} == 1 ) {
+ $template->param( CAN_user_reports => 1 );
}
- if ($in->{'type'} eq "intranet") {
+ }
+ if ( $in->{'type'} eq "intranet" ) {
$template->param(
- intranetcolorstylesheet => C4::Context->preference("intranetcolorstylesheet"),
+ intranetcolorstylesheet =>
+ C4::Context->preference("intranetcolorstylesheet"),
intranetstylesheet => C4::Context->preference("intranetstylesheet"),
IntranetNav => C4::Context->preference("IntranetNav"),
-
+ intranetuserjs => C4::Context->preference("intranetuserjs"),
+ TemplateEncoding => C4::Context->preference("TemplateEncoding"),
+ AmazonContent => C4::Context->preference("AmazonContent"),
+ LibraryName => C4::Context->preference("LibraryName"),
+ LoginBranchname => (C4::Context->userenv?C4::Context->userenv->{"branchname"}:"insecure"),
+ AutoLocation => C4::Context->preference("AutoLocation"),
+ hide_marc => C4::Context->preference("hide_marc"),
+ patronimages => C4::Context->preference("patronimages"),
+ "BiblioDefaultView".C4::Context->preference("BiblioDefaultView") => 1,
);
-
}
else {
+ warn "template type should be OPAC, here it is=[" . $in->{'type'} . "]"
+ unless ( $in->{'type'} eq 'opac' );
+ my $LibraryNameTitle = C4::Context->preference("LibraryName");
+ $LibraryNameTitle =~ s/<(?:\/?)(?:br|p)\s*(?:\/?)>/ /sgi;
+ $LibraryNameTitle =~ s/<(?:[^<>'"]|'(?:[^']*)'|"(?:[^"]*)")*>//sg;
$template->param(
- suggestion => C4::Context->preference("suggestion"),
- virtualshelves => C4::Context->preference("virtualshelves"),
- OpacNav => C4::Context->preference("OpacNav"),
- opacheader => C4::Context->preference("opacheader"),
- opaccredits => C4::Context->preference("opaccredits"),
- opacsmallimage => C4::Context->preference("opacsmallimage"),
- opaclayoutstylesheet => C4::Context->preference("opaclayoutstylesheet"),
- opaccolorstylesheet => C4::Context->preference("opaccolorstylesheet"),
- opaclanguagesdisplay => C4::Context->preference("opaclanguagesdisplay"),
- TemplateEncoding => C4::Context->preference("TemplateEncoding"),
- opacuserlogin => C4::Context->preference("opacuserlogin"),
- opacbookbag => C4::Context->preference("opacbookbag"),
+ suggestion => "" . C4::Context->preference("suggestion"),
+ virtualshelves => "" . C4::Context->preference("virtualshelves"),
+ OpacNav => "" . C4::Context->preference("OpacNav"),
+ opacheader => "" . C4::Context->preference("opacheader"),
+ opaccredits => "" . C4::Context->preference("opaccredits"),
+ opacsmallimage => "" . C4::Context->preference("opacsmallimage"),
+ opaclargeimage => "" . C4::Context->preference("opaclargeimage"),
+ opaclayoutstylesheet => "". C4::Context->preference("opaclayoutstylesheet"),
+ opaccolorstylesheet => "". C4::Context->preference("opaccolorstylesheet"),
+ opaclanguagesdisplay => "". C4::Context->preference("opaclanguagesdisplay"),
+ opacuserlogin => "" . C4::Context->preference("opacuserlogin"),
+ opacbookbag => "" . C4::Context->preference("opacbookbag"),
+ TemplateEncoding => "". C4::Context->preference("TemplateEncoding"),
+ AmazonContent => "" . C4::Context->preference("AmazonContent"),
+ LibraryName => "" . C4::Context->preference("LibraryName"),
+ LibraryNameTitle => "" . $LibraryNameTitle,
+ LoginBranchname => C4::Context->userenv?C4::Context->userenv->{"branchname"}:"",
+ OpacPasswordChange => C4::Context->preference("OpacPasswordChange"),
+ opacreadinghistory => C4::Context->preference("opacreadinghistory"),
+ opacuserjs => C4::Context->preference("opacuserjs"),
+ OpacCloud => C4::Context->preference("OpacCloud"),
+ OpacTopissue => C4::Context->preference("OpacTopissue"),
+ OpacAuthorities => C4::Context->preference("OpacAuthorities"),
+ OpacBrowser => C4::Context->preference("OpacBrowser"),
+ RequestOnOpac => C4::Context->preference("RequestOnOpac"),
+ reviewson => C4::Context->preference("reviewson"),
+ hide_marc => C4::Context->preference("hide_marc"),
+ patronimages => C4::Context->preference("patronimages"),
+ "BiblioDefaultView".C4::Context->preference("BiblioDefaultView") => 1,
);
}
- $template->param(
- TemplateEncoding => C4::Context->preference("TemplateEncoding"),
- AmazonContent => C4::Context->preference("AmazonContent"),
- LibraryName => C4::Context->preference("LibraryName"),
- );
- return ($template, $borrowernumber, $cookie);
+ return ( $template, $borrowernumber, $cookie );
}
-
=item checkauth
($userid, $cookie, $sessionID) = &checkauth($query, $noauth, $flagsrequired, $type);
@@ -296,11 +329,10 @@
=cut
-
-
sub checkauth {
- my $query=shift;
- # $authnotrequired will be set for scripts which will run without authentication
+ my $query = shift;
+
+# $authnotrequired will be set for scripts which will run without authentication
my $authnotrequired = shift;
my $flagsrequired = shift;
my $type = shift;
@@ -311,164 +343,244 @@
$timeout = 600 unless $timeout;
my $template_name;
- if ($type eq 'opac') {
+ if ( $type eq 'opac' ) {
$template_name = "opac-auth.tmpl";
- } else {
+ }
+ else {
$template_name = "auth.tmpl";
}
# state variables
my $loggedin = 0;
my %info;
- my ($userid, $cookie, $sessionID, $flags,$envcookie);
+ my ( $userid, $cookie, $sessionID, $flags, $envcookie );
my $logout = $query->param('logout.x');
- if ($userid = $ENV{'REMOTE_USER'}) {
+ if ( $userid = $ENV{'REMOTE_USER'} ) {
+
# Using Basic Authentication, no cookies required
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => '',
- -expires => '');
+ -expires => ''
+ );
$loggedin = 1;
- } elsif ($sessionID=$query->cookie('sessionID')) {
+ }
+ elsif ( $sessionID = $query->cookie('sessionID') ) {
C4::Context->_new_userenv($sessionID);
- if (my %hash=$query->cookie('userenv')){
+ if ( my %hash = $query->cookie('userenv') ) {
C4::Context::set_userenv(
- $hash{number},
- $hash{id},
- $hash{cardnumber},
- $hash{firstname},
- $hash{surname},
- $hash{branch},
- $hash{branchname},
- $hash{flags},
- $hash{emailaddress},
+ $hash{number}, $hash{id},
+ $hash{cardnumber}, $hash{firstname},
+ $hash{surname}, $hash{branch},
+ $hash{branchname}, $hash{flags},
+ $hash{emailaddress}, $hash{branchprinter}
);
}
- my ($ip , $lasttime);
+ my ( $ip, $lasttime );
- ($userid, $ip, $lasttime) = $dbh->selectrow_array(
+ ( $userid, $ip, $lasttime ) =
+ $dbh->selectrow_array(
"SELECT userid,ip,lasttime FROM sessions WHERE sessionid=?",
- undef, $sessionID);
+ undef, $sessionID );
if ($logout) {
+
# voluntary logout the user
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$sessionID = undef;
$userid = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged out at %30s (manually).\n", $userid, $ip, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged out at %30s (manually).\n", $userid,
+ $ip, $time;
close L;
}
if ($userid) {
- if ($lasttime<time()-$timeout) {
+ if ( $lasttime < time() - $timeout ) {
+
# timed logout
$info{'timed_out'} = 1;
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$userid = undef;
$sessionID = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged out at %30s (inactivity).\n", $userid, $ip, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged out at %30s (inactivity).\n",
+ $userid, $ip, $time;
close L;
- } elsif ($ip ne $ENV{'REMOTE_ADDR'}) {
+ }
+ elsif ( $ip ne $ENV{'REMOTE_ADDR'} ) {
+
# Different ip than originally logged in from
$info{'oldip'} = $ip;
$info{'newip'} = $ENV{'REMOTE_ADDR'};
$info{'different_ip'} = 1;
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$sessionID = undef;
$userid = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from logged out at %30s (ip changed from %16s to %16s).\n", $userid, $time, $ip, $info{'newip'};
+ my $time = localtime( time() );
+ printf L
+"%20s from logged out at %30s (ip changed from %16s to %16s).\n",
+ $userid, $time, $ip, $info{'newip'};
close L;
- } else {
- $cookie=$query->cookie(-name => 'sessionID',
+ }
+ else {
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
- $dbh->do("UPDATE sessions SET lasttime=? WHERE sessionID=?",
- undef, (time(), $sessionID));
- $flags = haspermission($dbh, $userid, $flagsrequired);
+ -expires => ''
+ );
+ $dbh->do( "UPDATE sessions SET lasttime=? WHERE sessionID=?",
+ undef, ( time(), $sessionID ) );
+ $flags = haspermission( $dbh, $userid, $flagsrequired );
if ($flags) {
$loggedin = 1;
- } else {
+ }
+ else {
$info{'nopermission'} = 1;
}
}
}
}
unless ($userid) {
- $sessionID=int(rand()*100000).'-'.time();
- $userid=$query->param('userid');
- my $password=$query->param('password');
+ $sessionID = int( rand() * 100000 ) . '-' . time();
+ $userid = $query->param('userid');
C4::Context->_new_userenv($sessionID);
- my ($return, $cardnumber) = checkpw($dbh,$userid,$password);
+ my $password = $query->param('password');
+ C4::Context->_new_userenv($sessionID);
+ my ( $return, $cardnumber ) = checkpw( $dbh, $userid, $password );
if ($return) {
- $dbh->do("DELETE FROM sessions WHERE sessionID=? AND userid=?",
- undef, ($sessionID, $userid));
- $dbh->do("INSERT INTO sessions (sessionID, userid, ip,lasttime) VALUES (?, ?, ?, ?)",
- undef, ($sessionID, $userid, $ENV{'REMOTE_ADDR'}, time()));
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=? AND userid=?",
+ undef, ( $sessionID, $userid ) );
+ $dbh->do(
+"INSERT INTO sessions (sessionID, userid, ip,lasttime) VALUES (?, ?, ?, ?)",
+ undef,
+ ( $sessionID, $userid, $ENV{'REMOTE_ADDR'}, time() )
+ );
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged in at %30s.\n", $userid, $ENV{'REMOTE_ADDR'}, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged in at %30s.\n", $userid,
+ $ENV{'REMOTE_ADDR'}, $time;
close L;
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
- if ($flags = haspermission($dbh, $userid, $flagsrequired)) {
+ -expires => ''
+ );
+ if ( $flags = haspermission( $dbh, $userid, $flagsrequired ) ) {
$loggedin = 1;
- } else {
+ }
+ else {
$info{'nopermission'} = 1;
C4::Context->_unset_userenv($sessionID);
}
- if ($return == 1){
- my ($bornum,$firstname,$surname,$userflags,$branchcode,$branchname,$emailaddress);
- my $sth=$dbh->prepare("select borrowernumber,firstname,surname,flags,borrowers.branchcode,branchname,emailaddress from borrowers left join branches on borrowers.branchcode=branches.branchcode where userid=?");
+ if ( $return == 1 ) {
+ my (
+ $borrowernumber, $firstname, $surname,
+ $userflags, $branchcode, $branchname,
+ $branchprinter, $emailaddress
+ );
+ my $sth =
+ $dbh->prepare(
+"select borrowernumber, firstname, surname, flags, borrowers.branchcode, branches.branchname as branchname,branches.branchprinter as branchprinter, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where userid=?"
+ );
$sth->execute($userid);
- ($bornum,$firstname,$surname,$userflags,$branchcode,$branchname, $emailaddress) = $sth->fetchrow if ($sth->rows);
-# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
- unless ($sth->rows){
- my $sth=$dbh->prepare("select borrowernumber,firstname,surname,flags,borrowers.branchcode,branchname,emailaddress from borrowers left join branches on borrowers.branchcode=branches.branchcode where cardnumber=?");
+ (
+ $borrowernumber, $firstname, $surname,
+ $userflags, $branchcode, $branchname,
+ $branchprinter, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
+
+# warn "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
+ unless ( $sth->rows ) {
+ my $sth =
+ $dbh->prepare(
+"select borrowernumber, firstname, surname, flags, borrowers.branchcode, branches.branchname as branchname, branches.branchprinter as branchprinter, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where cardnumber=?"
+ );
$sth->execute($cardnumber);
- ($bornum,$firstname,$surname,$userflags,$branchcode, $branchname,$emailaddress) = $sth->fetchrow if ($sth->rows);
-# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
- unless ($sth->rows){
+ (
+ $borrowernumber, $firstname, $surname,
+ $userflags, $branchcode, $branchname,
+ $branchprinter, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
+
+# warn "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
+ unless ( $sth->rows ) {
$sth->execute($userid);
- ($bornum,$firstname,$surname,$userflags,$branchcode, $branchname, $emailaddress) = $sth->fetchrow if ($sth->rows);
+ (
+ $borrowernumber, $firstname, $surname, $userflags,
+ $branchcode, $branchname, $branchprinter, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
+ }
+
+# warn "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
+ }
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# new op dev :
+# launch a sequence to check if we have a ip for the branch, if we have one we replace the branchcode of the userenv by the branch bound in the ip.
+ my $ip = $ENV{'REMOTE_ADDR'};
+ my $branches = GetBranches();
+ my @branchesloop;
+ foreach my $br ( keys %$branches ) {
+
+ # now we work with the treatment of ip
+ my $domain = $branches->{$br}->{'branchip'};
+ if ( $domain && $ip =~ /^$domain/ ) {
+ $branchcode = $branches->{$br}->{'branchcode'};
+
+ # new op dev : add the branchprinter and branchname in the cookie
+ $branchprinter = $branches->{$br}->{'branchprinter'};
+ $branchname = $branches->{$br}->{'branchname'};
}
-# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
}
my $hash = C4::Context::set_userenv(
- $bornum,
- $userid,
- $cardnumber,
- $firstname,
- $surname,
- $branchcode,
- $branchname,
- $userflags,
- $emailaddress,
+ $borrowernumber, $userid, $cardnumber,
+ $firstname, $surname, $branchcode,
+ $branchname, $userflags, $emailaddress,
+ $branchprinter,
);
-# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
- $envcookie=$query->cookie(-name => 'userenv',
+
+ $envcookie = $query->cookie(
+ -name => 'userenv',
-value => $hash,
- -expires => '');
- } elsif ($return == 2) {
+ -expires => ''
+ );
+ }
+ elsif ( $return == 2 ) {
+
#We suppose the user is the superlibrarian
my $hash = C4::Context::set_userenv(
- 0,0,
+ 0,
+ 0,
C4::Context->config('user'),
C4::Context->config('user'),
C4::Context->config('user'),
- "","",1,C4::Context->preference('KohaAdminEmailAddress')
+ "",
+ "SUPER",
+ 1,
+ C4::Context->preference('KohaAdminEmailAddress')
);
- $envcookie=$query->cookie(-name => 'userenv',
+ $envcookie = $query->cookie(
+ -name => 'userenv',
-value => $hash,
- -expires => '');
+ -expires => ''
+ );
}
- } else {
+ }
+ else {
if ($userid) {
$info{'invalid_username_or_password'} = 1;
C4::Context->_unset_userenv($sessionID);
@@ -476,124 +588,180 @@
}
}
my $insecure = C4::Context->boolean_preference('insecure');
+
# finished authentification, now respond
- if ($loggedin || $authnotrequired || (defined($insecure) && $insecure)) {
+ if ( $loggedin || $authnotrequired || ( defined($insecure) && $insecure ) )
+ {
+
# successful login
unless ($cookie) {
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => '',
- -expires => '');
+ -expires => ''
+ );
}
- if ($envcookie){
- return ($userid, [$cookie,$envcookie], $sessionID, $flags)
- } else {
- return ($userid, $cookie, $sessionID, $flags);
+ if ($envcookie) {
+ return ( $userid, [ $cookie, $envcookie ], $sessionID, $flags );
+ }
+ else {
+ return ( $userid, $cookie, $sessionID, $flags );
}
}
+
# else we have a problem...
# get the inputs from the incoming query
- my @inputs =();
- foreach my $name (param $query) {
- (next) if ($name eq 'userid' || $name eq 'password');
+ my @inputs = ();
+ foreach my $name ( param $query) {
+ (next) if ( $name eq 'userid' || $name eq 'password' );
my $value = $query->param($name);
- push @inputs, {name => $name , value => $value};
+ push @inputs, { name => $name, value => $value };
}
- my $template = gettemplate($template_name, $type,$query);
- $template->param(INPUTS => \@inputs,
- intranetcolorstylesheet => C4::Context->preference("intranetcolorstylesheet"),
+ my $template = gettemplate( $template_name, $type, $query );
+ $template->param(
+ INPUTS => \@inputs,
+ suggestion => C4::Context->preference("suggestion"),
+ virtualshelves => C4::Context->preference("virtualshelves"),
+ opaclargeimage => C4::Context->preference("opaclargeimage"),
+ LibraryName => C4::Context->preference("LibraryName"),
+ OpacNav => C4::Context->preference("OpacNav"),
+ opaccredits => C4::Context->preference("opaccredits"),
+ opacreadinghistory => C4::Context->preference("opacreadinghistory"),
+ opacsmallimage => C4::Context->preference("opacsmallimage"),
+ opaclayoutstylesheet => C4::Context->preference("opaclayoutstylesheet"),
+ opaccolorstylesheet => C4::Context->preference("opaccolorstylesheet"),
+ opaclanguagesdisplay => C4::Context->preference("opaclanguagesdisplay"),
+ opacuserjs => C4::Context->preference("opacuserjs"),
+
+ intranetcolorstylesheet =>
+ C4::Context->preference("intranetcolorstylesheet"),
intranetstylesheet => C4::Context->preference("intranetstylesheet"),
IntranetNav => C4::Context->preference("IntranetNav"),
- opacnav => C4::Context->preference("OpacNav"),
+ intranetuserjs => C4::Context->preference("intranetuserjs"),
TemplateEncoding => C4::Context->preference("TemplateEncoding"),
);
- $template->param(loginprompt => 1) unless $info{'nopermission'};
+ $template->param( loginprompt => 1 ) unless $info{'nopermission'};
- my $self_url = $query->url(-absolute => 1);
- $template->param(url => $self_url, LibraryName=> => C4::Context->preference("LibraryName"),);
- $template->param(\%info);
- $cookie=$query->cookie(-name => 'sessionID',
+ my $self_url = $query->url( -absolute => 1 );
+ $template->param(
+ url => $self_url,
+ LibraryName => => C4::Context->preference("LibraryName"),
+ );
+ $template->param( \%info );
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
+ -expires => ''
+ );
print $query->header(
- -type => "text/html",
- -charset=>"utf-8",
+ -type => guesstype( $template->output ),
-cookie => $cookie
- ), $template->output;
+ ),
+ $template->output;
exit;
}
-
-
-
sub checkpw {
- my ($dbh, $userid, $password) = @_;
-# INTERNAL AUTH
- my $sth=$dbh->prepare("select password,cardnumber from borrowers where userid=?");
+ my ( $dbh, $userid, $password ) = @_;
+
+ # INTERNAL AUTH
+ my $sth =
+ $dbh->prepare(
+"select password,cardnumber,borrowernumber,userid,firstname,surname,branchcode,flags from borrowers where userid=?"
+ );
$sth->execute($userid);
- if ($sth->rows) {
- my ($md5password,$cardnumber) = $sth->fetchrow;
- if (md5_base64($password) eq $md5password) {
- return 1,$cardnumber;
+ if ( $sth->rows ) {
+ my ( $md5password, $cardnumber, $borrowernumber, $userid, $firstname,
+ $surname, $branchcode, $flags )
+ = $sth->fetchrow;
+ if ( md5_base64($password) eq $md5password ) {
+
+ C4::Context->set_userenv( "$borrowernumber", $userid, $cardnumber,
+ $firstname, $surname, $branchcode, $flags );
+ return 1, $cardnumber;
}
}
- my $sth=$dbh->prepare("select password from borrowers where cardnumber=?");
+ $sth =
+ $dbh->prepare(
+"select password,cardnumber,borrowernumber,userid, firstname,surname,branchcode,flags from borrowers where cardnumber=?"
+ );
$sth->execute($userid);
- if ($sth->rows) {
- my ($md5password) = $sth->fetchrow;
- if (md5_base64($password) eq $md5password) {
- return 1,$userid;
+ if ( $sth->rows ) {
+ my ( $md5password, $cardnumber, $borrowernumber, $userid, $firstname,
+ $surname, $branchcode, $flags )
+ = $sth->fetchrow;
+ if ( md5_base64($password) eq $md5password ) {
+
+ C4::Context->set_userenv( $borrowernumber, $userid, $cardnumber,
+ $firstname, $surname, $branchcode, $flags );
+ return 1, $userid;
}
}
- if ($userid eq C4::Context->config('user') && $password eq C4::Context->config('pass')) {
- # Koha superuser account
+ if ( $userid && $userid eq C4::Context->config('user')
+ && "$password" eq C4::Context->config('pass') )
+ {
+
+# Koha superuser account
+# C4::Context->set_userenv(0,0,C4::Context->config('user'),C4::Context->config('user'),C4::Context->config('user'),"",1);
return 2;
}
- if ($userid eq 'demo' && $password eq 'demo' && C4::Context->config('demo')) {
- # DEMO => the demo user is allowed to do everything (if demo set to 1 in koha.conf
- # some features won't be effective : modify systempref, modify MARC structure,
+ if ( $userid && $userid eq 'demo'
+ && "$password" eq 'demo'
+ && C4::Context->config('demo') )
+ {
+
+# DEMO => the demo user is allowed to do everything (if demo set to 1 in koha.conf
+# some features won't be effective : modify systempref, modify MARC structure,
return 2;
}
return 0;
}
sub getuserflags {
- my $cardnumber=shift;
- my $dbh=shift;
+ my $cardnumber = shift;
+ my $dbh = shift;
my $userflags;
- my $sth=$dbh->prepare("SELECT flags FROM borrowers WHERE cardnumber=?");
+ my $sth = $dbh->prepare("SELECT flags FROM borrowers WHERE cardnumber=?");
$sth->execute($cardnumber);
my ($flags) = $sth->fetchrow;
- $sth=$dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
+ $flags = 0 unless $flags;
+ $sth = $dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
$sth->execute;
- while (my ($bit, $flag, $defaulton) = $sth->fetchrow) {
- if (($flags & (2**$bit)) || $defaulton) {
- $userflags->{$flag}=1;
+
+ while ( my ( $bit, $flag, $defaulton ) = $sth->fetchrow ) {
+ if ( ( $flags & ( 2**$bit ) ) || $defaulton ) {
+ $userflags->{$flag} = 1;
+ }
+ else {
+ $userflags->{$flag} = 0;
}
}
return $userflags;
}
sub haspermission {
- my ($dbh, $userid, $flagsrequired) = @_;
- my $sth=$dbh->prepare("SELECT cardnumber FROM borrowers WHERE userid=?");
+ my ( $dbh, $userid, $flagsrequired ) = @_;
+ my $sth = $dbh->prepare("SELECT cardnumber FROM borrowers WHERE userid=?");
$sth->execute($userid);
my ($cardnumber) = $sth->fetchrow;
- ($cardnumber) || ($cardnumber=$userid);
- my $flags=getuserflags($cardnumber,$dbh);
+ ($cardnumber) || ( $cardnumber = $userid );
+ my $flags = getuserflags( $cardnumber, $dbh );
my $configfile;
- if ($userid eq C4::Context->config('user')) {
+ if ( $userid eq C4::Context->config('user') ) {
+
# Super User Account from /etc/koha.conf
- $flags->{'superlibrarian'}=1;
+ $flags->{'superlibrarian'} = 1;
}
- if ($userid eq 'demo' && C4::Context->config('demo')) {
+ if ( $userid eq 'demo' && C4::Context->config('demo') ) {
+
# Demo user that can do "anything" (demo=1 in /etc/koha.conf)
- $flags->{'superlibrarian'}=1;
+ $flags->{'superlibrarian'} = 1;
}
return $flags if $flags->{superlibrarian};
- foreach (keys %$flagsrequired) {
+ foreach ( keys %$flagsrequired ) {
return $flags if $flags->{$_};
}
return 0;
@@ -602,11 +770,11 @@
sub getborrowernumber {
my ($userid) = @_;
my $dbh = C4::Context->dbh;
- for my $field ('userid', 'cardnumber') {
- my $sth=$dbh->prepare
- ("select borrowernumber from borrowers where $field=?");
+ for my $field ( 'userid', 'cardnumber' ) {
+ my $sth =
+ $dbh->prepare("select borrowernumber from borrowers where $field=?");
$sth->execute($userid);
- if ($sth->rows) {
+ if ( $sth->rows ) {
my ($bnumber) = $sth->fetchrow;
return $bnumber;
}
Index: Auth_with_ldap.pm
===================================================================
RCS file: /sources/koha/koha/C4/Auth_with_ldap.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- Auth_with_ldap.pm 6 Jan 2006 16:39:37 -0000 1.5
+++ Auth_with_ldap.pm 9 Mar 2007 14:31:47 -0000 1.6
@@ -29,6 +29,7 @@
use C4::Interface::CGI::Output;
use C4::Circulation::Circ2; # getpatroninformation
use C4::Members;
+
# use Net::LDAP;
# use Net::LDAP qw(:all);
@@ -53,7 +54,7 @@
query => $query,
type => "opac",
authnotrequired => 1,
- flagsrequired => {borrow => 1},
+ flagsrequired => {circulate => 1},
});
print $query->header(
@@ -85,8 +86,6 @@
=cut
-
-
@ISA = qw(Exporter);
@EXPORT = qw(
&checkauth
@@ -100,7 +99,7 @@
query => $query,
type => "opac",
authnotrequired => 1,
- flagsrequired => {borrow => 1},
+ flagsrequired => {circulate => 1},
});
This call passes the C<query>, C<flagsrequired> and C<authnotrequired>
@@ -119,99 +118,115 @@
=cut
-
sub get_template_and_user {
my $in = shift;
- my $template = gettemplate($in->{'template_name'}, $in->{'type'},$in->{'query'});
- my ($user, $cookie, $sessionID, $flags)
- = checkauth($in->{'query'}, $in->{'authnotrequired'}, $in->{'flagsrequired'}, $in->{'type'});
+ my $template =
+ gettemplate( $in->{'template_name'}, $in->{'type'}, $in->{'query'} );
+ my ( $user, $cookie, $sessionID, $flags ) = checkauth(
+ $in->{'query'},
+ $in->{'authnotrequired'},
+ $in->{'flagsrequired'},
+ $in->{'type'}
+ );
my $borrowernumber;
if ($user) {
- $template->param(loggedinusername => $user);
- $template->param(sessionID => $sessionID);
+ $template->param( loggedinusername => $user );
+ $template->param( sessionID => $sessionID );
$borrowernumber = getborrowernumber($user);
- my ($borr, $alternativeflags) = getpatroninformation(undef, $borrowernumber);
+ my ( $borr, $alternativeflags ) =
+ getpatroninformation( undef, $borrowernumber );
my @bordat;
$bordat[0] = $borr;
- $template->param(USER_INFO => \@bordat,
- );
+ $template->param( USER_INFO => \@bordat, );
+
# We are going to use the $flags returned by checkauth
# to create the template's parameters that will indicate
# which menus the user can access.
- if ($flags && $flags->{superlibrarian} == 1)
- {
- $template->param(CAN_user_circulate => 1);
- $template->param(CAN_user_catalogue => 1);
- $template->param(CAN_user_parameters => 1);
- $template->param(CAN_user_borrowers => 1);
- $template->param(CAN_user_permission => 1);
- $template->param(CAN_user_reserveforothers => 1);
- $template->param(CAN_user_borrow => 1);
- $template->param(CAN_user_reserveforself => 1);
- $template->param(CAN_user_editcatalogue => 1);
- $template->param(CAN_user_updatecharge => 1);
- $template->param(CAN_user_acquisition => 1);
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
-
- if ($flags && $flags->{circulate} == 1) {
- $template->param(CAN_user_circulate => 1); }
-
- if ($flags && $flags->{catalogue} == 1) {
- $template->param(CAN_user_catalogue => 1); }
-
-
- if ($flags && $flags->{parameters} == 1) {
- $template->param(CAN_user_parameters => 1);
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
-
-
- if ($flags && $flags->{borrowers} == 1) {
- $template->param(CAN_user_borrowers => 1); }
-
+ if ( $flags && $flags->{superlibrarian} == 1 ) {
+ $template->param( CAN_user_circulate => 1 );
+ $template->param( CAN_user_catalogue => 1 );
+ $template->param( CAN_user_parameters => 1 );
+ $template->param( CAN_user_borrowers => 1 );
+ $template->param( CAN_user_permission => 1 );
+ $template->param( CAN_user_reserveforothers => 1 );
+ $template->param( CAN_user_borrow => 1 );
+ $template->param( CAN_user_editcatalogue => 1 );
+ $template->param( CAN_user_updatecharge => 1 );
+ $template->param( CAN_user_editauthorities => 1 );
+ $template->param( CAN_user_acquisition => 1 );
+ $template->param( CAN_user_management => 1 );
+ $template->param( CAN_user_tools => 1 );
+ $template->param( CAN_user_serials => 1 );
+ $template->param( CAN_user_reports => 1 );
+ }
+ if ( $flags && $flags->{circulate} == 1 ) {
+ $template->param( CAN_user_circulate => 1 );
+ }
- if ($flags && $flags->{permissions} == 1) {
- $template->param(CAN_user_permission => 1); }
+ if ( $flags && $flags->{catalogue} == 1 ) {
+ $template->param( CAN_user_catalogue => 1 );
+ }
- if ($flags && $flags->{reserveforothers} == 1) {
- $template->param(CAN_user_reserveforothers => 1); }
+ if ( $flags && $flags->{parameters} == 1 ) {
+ $template->param( CAN_user_parameters => 1 );
+ $template->param( CAN_user_management => 1 );
+ $template->param( CAN_user_tools => 1 );
+ }
+ if ( $flags && $flags->{borrowers} == 1 ) {
+ $template->param( CAN_user_borrowers => 1 );
+ }
- if ($flags && $flags->{borrow} == 1) {
- $template->param(CAN_user_borrow => 1); }
+ if ( $flags && $flags->{permissions} == 1 ) {
+ $template->param( CAN_user_permission => 1 );
+ }
+ if ( $flags && $flags->{reserveforothers} == 1 ) {
+ $template->param( CAN_user_reserveforothers => 1 );
+ }
- if ($flags && $flags->{reserveforself} == 1) {
- $template->param(CAN_user_reserveforself => 1); }
+ if ( $flags && $flags->{borrow} == 1 ) {
+ $template->param( CAN_user_borrow => 1 );
+ }
+ if ( $flags && $flags->{editcatalogue} == 1 ) {
+ $template->param( CAN_user_editcatalogue => 1 );
+ }
- if ($flags && $flags->{editcatalogue} == 1) {
- $template->param(CAN_user_editcatalogue => 1); }
+ if ( $flags && $flags->{updatecharges} == 1 ) {
+ $template->param( CAN_user_updatecharge => 1 );
+ }
+ if ( $flags && $flags->{acquisition} == 1 ) {
+ $template->param( CAN_user_acquisition => 1 );
+ }
- if ($flags && $flags->{updatecharges} == 1) {
- $template->param(CAN_user_updatecharge => 1); }
+ if ( $flags && $flags->{management} == 1 ) {
+ $template->param( CAN_user_management => 1 );
+ $template->param( CAN_user_tools => 1 );
+ }
- if ($flags && $flags->{acquisition} == 1) {
- $template->param(CAN_user_acquisition => 1); }
+ if ( $flags && $flags->{tools} == 1 ) {
+ $template->param( CAN_user_tools => 1 );
+ }
+ if ( $flags && $flags->{editauthorities} == 1 ) {
+ $template->param( CAN_user_editauthorities => 1 );
+ }
- if ($flags && $flags->{management} == 1) {
- $template->param(CAN_user_management => 1);
- $template->param(CAN_user_tools => 1); }
+ if ( $flags && $flags->{serials} == 1 ) {
+ $template->param( CAN_user_serials => 1 );
+ }
- if ($flags && $flags->{tools} == 1) {
- $template->param(CAN_user_tools => 1); }
+ if ( $flags && $flags->{reports} == 1 ) {
+ $template->param( CAN_user_reports => 1 );
}
- $template->param(
- LibraryName => C4::Context->preference("LibraryName"),
- );
- return ($template, $borrowernumber, $cookie);
+ }
+ $template->param( LibraryName => C4::Context->preference("LibraryName"), );
+ return ( $template, $borrowernumber, $cookie );
}
-
=item checkauth
($userid, $cookie, $sessionID) = &checkauth($query, $noauth, $flagsrequired, $type);
@@ -270,11 +285,10 @@
=cut
-
-
sub checkauth {
- my $query=shift;
- # $authnotrequired will be set for scripts which will run without authentication
+ my $query = shift;
+
+# $authnotrequired will be set for scripts which will run without authentication
my $authnotrequired = shift;
my $flagsrequired = shift;
my $type = shift;
@@ -285,157 +299,206 @@
$timeout = 600 unless $timeout;
my $template_name;
- if ($type eq 'opac') {
+ if ( $type eq 'opac' ) {
$template_name = "opac-auth.tmpl";
- } else {
+ }
+ else {
$template_name = "auth.tmpl";
}
# state variables
my $loggedin = 0;
my %info;
- my ($userid, $cookie, $sessionID, $flags,$envcookie);
+ my ( $userid, $cookie, $sessionID, $flags, $envcookie );
my $logout = $query->param('logout.x');
- if ($userid = $ENV{'REMOTE_USER'}) {
+ if ( $userid = $ENV{'REMOTE_USER'} ) {
+
# Using Basic Authentication, no cookies required
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => '',
- -expires => '');
+ -expires => ''
+ );
$loggedin = 1;
- } elsif ($sessionID=$query->cookie('sessionID')) {
+ }
+ elsif ( $sessionID = $query->cookie('sessionID') ) {
C4::Context->_new_userenv($sessionID);
- if (my %hash=$query->cookie('userenv')){
+ if ( my %hash = $query->cookie('userenv') ) {
C4::Context::set_userenv(
- $hash{number},
- $hash{id},
- $hash{cardnumber},
- $hash{firstname},
- $hash{surname},
- $hash{branch},
- $hash{flags},
- $hash{emailaddress},
+ $hash{number}, $hash{id}, $hash{cardnumber},
+ $hash{firstname}, $hash{surname}, $hash{branch},
+ $hash{flags}, $hash{emailaddress},
);
}
- my ($ip , $lasttime);
- ($userid, $ip, $lasttime) = $dbh->selectrow_array(
+ my ( $ip, $lasttime );
+ ( $userid, $ip, $lasttime ) =
+ $dbh->selectrow_array(
"SELECT userid,ip,lasttime FROM sessions WHERE sessionid=?",
- undef, $sessionID);
+ undef, $sessionID );
if ($logout) {
+
# voluntary logout the user
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$sessionID = undef;
$userid = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged out at %30s (manually).\n", $userid, $ip, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged out at %30s (manually).\n", $userid,
+ $ip, $time;
close L;
}
if ($userid) {
- if ($lasttime<time()-$timeout) {
+ if ( $lasttime < time() - $timeout ) {
+
# timed logout
$info{'timed_out'} = 1;
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$userid = undef;
$sessionID = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged out at %30s (inactivity).\n", $userid, $ip, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged out at %30s (inactivity).\n",
+ $userid, $ip, $time;
close L;
- } elsif ($ip ne $ENV{'REMOTE_ADDR'}) {
+ }
+ elsif ( $ip ne $ENV{'REMOTE_ADDR'} ) {
+
# Different ip than originally logged in from
$info{'oldip'} = $ip;
$info{'newip'} = $ENV{'REMOTE_ADDR'};
$info{'different_ip'} = 1;
- $dbh->do("DELETE FROM sessions WHERE sessionID=?", undef, $sessionID);
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=?",
+ undef, $sessionID );
C4::Context->_unset_userenv($sessionID);
$sessionID = undef;
$userid = undef;
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from logged out at %30s (ip changed from %16s to %16s).\n", $userid, $time, $ip, $info{'newip'};
+ my $time = localtime( time() );
+ printf L
+"%20s from logged out at %30s (ip changed from %16s to %16s).\n",
+ $userid, $time, $ip, $info{'newip'};
close L;
- } else {
- $cookie=$query->cookie(-name => 'sessionID',
+ }
+ else {
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
- $dbh->do("UPDATE sessions SET lasttime=? WHERE sessionID=?",
- undef, (time(), $sessionID));
- $flags = haspermission($dbh, $userid, $flagsrequired);
+ -expires => ''
+ );
+ $dbh->do( "UPDATE sessions SET lasttime=? WHERE sessionID=?",
+ undef, ( time(), $sessionID ) );
+ $flags = haspermission( $dbh, $userid, $flagsrequired );
if ($flags) {
$loggedin = 1;
- } else {
+ }
+ else {
$info{'nopermission'} = 1;
}
}
}
}
unless ($userid) {
- $sessionID=int(rand()*100000).'-'.time();
- $userid=$query->param('userid');
- my $password=$query->param('password');
+ $sessionID = int( rand() * 100000 ) . '-' . time();
+ $userid = $query->param('userid');
+ my $password = $query->param('password');
C4::Context->_new_userenv($sessionID);
- my ($return, $cardnumber) = checkpw($dbh,$userid,$password);
+ my ( $return, $cardnumber ) = checkpw( $dbh, $userid, $password );
if ($return) {
- $dbh->do("DELETE FROM sessions WHERE sessionID=? AND userid=?",
- undef, ($sessionID, $userid));
- $dbh->do("INSERT INTO sessions (sessionID, userid, ip,lasttime) VALUES (?, ?, ?, ?)",
- undef, ($sessionID, $userid, $ENV{'REMOTE_ADDR'}, time()));
+ $dbh->do( "DELETE FROM sessions WHERE sessionID=? AND userid=?",
+ undef, ( $sessionID, $userid ) );
+ $dbh->do(
+"INSERT INTO sessions (sessionID, userid, ip,lasttime) VALUES (?, ?, ?, ?)",
+ undef,
+ ( $sessionID, $userid, $ENV{'REMOTE_ADDR'}, time() )
+ );
open L, ">>/tmp/sessionlog";
- my $time=localtime(time());
- printf L "%20s from %16s logged in at %30s.\n", $userid, $ENV{'REMOTE_ADDR'}, $time;
+ my $time = localtime( time() );
+ printf L "%20s from %16s logged in at %30s.\n", $userid,
+ $ENV{'REMOTE_ADDR'}, $time;
close L;
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
- if ($flags = haspermission($dbh, $userid, $flagsrequired)) {
+ -expires => ''
+ );
+ if ( $flags = haspermission( $dbh, $userid, $flagsrequired ) ) {
$loggedin = 1;
- } else {
+ }
+ else {
$info{'nopermission'} = 1;
C4::Context->_unset_userenv($sessionID);
}
- if ($return == 1){
- my ($bornum,$firstname,$surname,$userflags,$branchcode,$emailaddress);
- my $sth=$dbh->prepare("select borrowernumber,firstname,surname,flags,branchcode,emailaddress from borrowers where userid=?");
+ if ( $return == 1 ) {
+ my ( $borrowernumber, $firstname, $surname, $userflags,
+ $branchcode, $emailaddress );
+ my $sth =
+ $dbh->prepare(
+"select borrowernumber,firstname,surname,flags,branchcode,emailaddress from borrowers where userid=?"
+ );
$sth->execute($userid);
- ($bornum,$firstname,$surname,$userflags,$branchcode,$emailaddress) = $sth->fetchrow if ($sth->rows);
- unless ($sth->rows){
- my $sth=$dbh->prepare("select borrowernumber,firstname,surname,flags,branchcode,emailaddress from borrowers where cardnumber=?");
+ (
+ $borrowernumber, $firstname, $surname, $userflags,
+ $branchcode, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
+ unless ( $sth->rows ) {
+ my $sth =
+ $dbh->prepare(
+"select borrowernumber,firstname,surname,flags,branchcode,emailaddress from borrowers where cardnumber=?"
+ );
$sth->execute($cardnumber);
- ($bornum,$firstname,$surname,$userflags,$branchcode,$emailaddress) = $sth->fetchrow if ($sth->rows);
- unless ($sth->rows){
+ (
+ $borrowernumber, $firstname, $surname, $userflags,
+ $branchcode, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
+ unless ( $sth->rows ) {
$sth->execute($userid);
- ($bornum,$firstname,$surname,$userflags,$branchcode,$emailaddress) = $sth->fetchrow if ($sth->rows);
+ (
+ $borrowernumber, $firstname, $surname, $userflags,
+ $branchcode, $emailaddress
+ )
+ = $sth->fetchrow
+ if ( $sth->rows );
}
}
- my $hash = C4::Context::set_userenv(
- $bornum,
- $userid,
- $cardnumber,
- $firstname,
- $surname,
- $branchcode,
- $userflags,
- $emailaddress,
- );
- $envcookie=$query->cookie(-name => 'userenv',
+ my $hash =
+ C4::Context::set_userenv( $borrowernumber, $userid,
+ $cardnumber, $firstname, $surname, $branchcode, $userflags,
+ $emailaddress, );
+ $envcookie = $query->cookie(
+ -name => 'userenv',
-value => $hash,
- -expires => '');
- } elsif ($return == 2) {
+ -expires => ''
+ );
+ }
+ elsif ( $return == 2 ) {
+
#We suppose the user is the superlibrarian
my $hash = C4::Context::set_userenv(
- 0,0,
+ 0,
+ 0,
C4::Context->config('user'),
C4::Context->config('user'),
C4::Context->config('user'),
- "",1,C4::Context->preference('KohaAdminEmailAddress')
+ "",
+ 1,
+ C4::Context->preference('KohaAdminEmailAddress')
);
- $envcookie=$query->cookie(-name => 'userenv',
+ $envcookie = $query->cookie(
+ -name => 'userenv',
-value => $hash,
- -expires => '');
+ -expires => ''
+ );
}
- } else {
+ }
+ else {
if ($userid) {
$info{'invalid_username_or_password'} = 1;
C4::Context->_unset_userenv($sessionID);
@@ -443,48 +506,56 @@
}
}
my $insecure = C4::Context->boolean_preference('insecure');
+
# finished authentification, now respond
- if ($loggedin || $authnotrequired || (defined($insecure) && $insecure)) {
+ if ( $loggedin || $authnotrequired || ( defined($insecure) && $insecure ) )
+ {
+
# successful login
unless ($cookie) {
- $cookie=$query->cookie(-name => 'sessionID',
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => '',
- -expires => '');
+ -expires => ''
+ );
+ }
+ if ($envcookie) {
+ return ( $userid, [ $cookie, $envcookie ], $sessionID, $flags );
}
- if ($envcookie){
- return ($userid, [$cookie,$envcookie], $sessionID, $flags)
- } else {
- return ($userid, $cookie, $sessionID, $flags);
+ else {
+ return ( $userid, $cookie, $sessionID, $flags );
}
}
+
# else we have a problem...
# get the inputs from the incoming query
- my @inputs =();
- foreach my $name (param $query) {
- (next) if ($name eq 'userid' || $name eq 'password');
+ my @inputs = ();
+ foreach my $name ( param $query) {
+ (next) if ( $name eq 'userid' || $name eq 'password' );
my $value = $query->param($name);
- push @inputs, {name => $name , value => $value};
+ push @inputs, { name => $name, value => $value };
}
- my $template = gettemplate($template_name, $type,$query);
- $template->param(INPUTS => \@inputs);
- $template->param(loginprompt => 1) unless $info{'nopermission'};
-
- my $self_url = $query->url(-absolute => 1);
- $template->param(url => $self_url);
- $template->param(\%info);
- $cookie=$query->cookie(-name => 'sessionID',
+ my $template = gettemplate( $template_name, $type, $query );
+ $template->param( INPUTS => \@inputs );
+ $template->param( loginprompt => 1 ) unless $info{'nopermission'};
+
+ my $self_url = $query->url( -absolute => 1 );
+ $template->param( url => $self_url );
+ $template->param( \%info );
+ $cookie = $query->cookie(
+ -name => 'sessionID',
-value => $sessionID,
- -expires => '');
+ -expires => ''
+ );
print $query->header(
- -type => guesstype($template->output),
+ -type => guesstype( $template->output ),
-cookie => $cookie
- ), $template->output;
+ ),
+ $template->output;
exit;
}
-
-
# this checkpw is a LDAP based one
# it connects to LDAP (anonymous)
# it retrieve $userid a-login
@@ -493,8 +564,11 @@
# and calls the memberadd if necessary
sub checkpw {
- my ($dbh, $userid, $password) = @_;
- if ($userid eq C4::Context->config('user') && $password eq C4::Context->config('pass')) {
+ my ( $dbh, $userid, $password ) = @_;
+ if ( $userid eq C4::Context->config('user')
+ && $password eq C4::Context->config('pass') )
+ {
+
# Koha superuser account
return 2;
}
@@ -504,51 +578,59 @@
##################################################
# LDAP connexion parameters
my $ldapserver = 'your.ldap.server.com';
+
# Infos to do an anonymous bind
my $ldapinfos = 'a-section=people,dc=emn,dc=fr ';
my $name = "a-section=people,dc=emn,dc=fr";
- my $db = Net::LDAP->new( $ldapserver );
+ my $db = Net::LDAP->new($ldapserver);
# do an anonymous bind
- my $res =$db->bind();
- if($res->code) {
+ my $res = $db->bind();
+ if ( $res->code ) {
+
# auth refused
warn "LDAP Auth impossible : server not responding";
return 0;
- } else {
- my $userdnsearch = $db->search(base => $name,
- filter =>"(a-login=$userid)",
+ }
+ else {
+ my $userdnsearch = $db->search(
+ base => $name,
+ filter => "(a-login=$userid)",
);
- if($userdnsearch->code || ! ( $userdnsearch-> count eq 1 ) ) {
+ if ( $userdnsearch->code || !( $userdnsearch->count eq 1 ) ) {
warn "LDAP Auth impossible : user unknown in LDAP";
return 0;
- };
+ }
- my $userldapentry=$userdnsearch -> shift_entry;
- my $cmpmesg = $db -> compare ( $userldapentry, attr => 'a-weak', value => $password );
+ my $userldapentry = $userdnsearch->shift_entry;
+ my $cmpmesg =
+ $db->compare( $userldapentry, attr => 'a-weak', value => $password );
## HACK LMK
## ligne originale
# if( $cmpmesg -> code != 6 ) {
- if( ( $cmpmesg -> code != 6 ) && ! ( $password eq "kivabien" ) ) {
+ if ( ( $cmpmesg->code != 6 ) && !( $password eq "kivabien" ) ) {
warn "LDAP Auth impossible : wrong password";
return 0;
- };
+ }
+
# build LDAP hash
my %memberhash;
- my $x =$userldapentry->{asn}{attributes};
+ my $x = $userldapentry->{asn}{attributes};
my $key;
- foreach my $k ( @$x) {
- foreach my $k2 (keys %$k) {
- if ($k2 eq 'type') {
+ foreach my $k (@$x) {
+ foreach my $k2 ( keys %$k ) {
+ if ( $k2 eq 'type' ) {
$key = $$k{$k2};
- } else {
+ }
+ else {
my $a = @$k{$k2};
foreach my $k3 (@$a) {
- $memberhash{$key} .= $k3." ";
+ $memberhash{$key} .= $k3 . " ";
}
}
}
}
+
#
# BUILD %borrower to CREATE or MODIFY BORROWER
# change $memberhash{'xxx'} to fit your ldap structure.
@@ -558,8 +640,11 @@
$borrower{cardnumber} = $userid;
$borrower{firstname} = $memberhash{givenName}; # MANDATORY FIELD
$borrower{surname} = $memberhash{sn}; # MANDATORY FIELD
- $borrower{initials} = substr($borrower{firstname},0,1).substr($borrower{surname},0,1)." "; # MANDATORY FIELD
- $borrower{streetaddress} = $memberhash{l}." "; # MANDATORY FIELD
+ $borrower{initials} =
+ substr( $borrower{firstname}, 0, 1 )
+ . substr( $borrower{surname}, 0, 1 )
+ . " "; # MANDATORY FIELD
+ $borrower{streetaddress} = $memberhash{l} . " "; # MANDATORY FIELD
$borrower{city} = " "; # MANDATORY FIELD
$borrower{phone} = " "; # MANDATORY FIELD
$borrower{branchcode} = $memberhash{branch}; # MANDATORY FIELD
@@ -570,88 +655,107 @@
### No change needed after this line (unless there's a bug ;-) )
##################################################
# check if borrower exists
- my $sth=$dbh->prepare("select password from borrowers where cardnumber=?");
+ my $sth =
+ $dbh->prepare("select password from borrowers where cardnumber=?");
$sth->execute($userid);
- if ($sth->rows) {
+ if ( $sth->rows ) {
+
# it exists, MODIFY
-# warn "MODIF borrower";
- my $sth2 = $dbh->prepare("update borrowers set firstname=?,surname=?,initials=?,streetaddress=?,city=?,phone=?, categorycode=?,branchcode=?,emailaddress=?,sort1=? where cardnumber=?");
- $sth2->execute($borrower{firstname},$borrower{surname},$borrower{initials},
- $borrower{streetaddress},$borrower{city},$borrower{phone},
- $borrower{categorycode},$borrower{branchcode},$borrower{emailaddress},
- $borrower{sort1} ,$userid);
- } else {
+ # warn "MODIF borrower";
+ my $sth2 =
+ $dbh->prepare(
+"update borrowers set firstname=?,surname=?,initials=?,streetaddress=?,city=?,phone=?, categorycode=?,branchcode=?,emailaddress=?,sort1=? where cardnumber=?"
+ );
+ $sth2->execute(
+ $borrower{firstname}, $borrower{surname},
+ $borrower{initials}, $borrower{streetaddress},
+ $borrower{city}, $borrower{phone},
+ $borrower{categorycode}, $borrower{branchcode},
+ $borrower{emailaddress}, $borrower{sort1},
+ $userid
+ );
+ }
+ else {
+
# it does not exists, ADD borrower
-# warn "ADD borrower";
+ # warn "ADD borrower";
my $borrowerid = newmember(%borrower);
}
+
#
# CREATE or MODIFY PASSWORD/LOGIN
#
# search borrowerid
- $sth = $dbh->prepare("select borrowernumber from borrowers where cardnumber=?");
+ $sth =
+ $dbh->prepare(
+ "select borrowernumber from borrowers where cardnumber=?");
$sth->execute($userid);
- my ($borrowerid)=$sth->fetchrow;
-# warn "change password for $borrowerid setting $password";
- my $digest=md5_base64($password);
- changepassword($userid,$borrowerid,$digest);
+ my ($borrowerid) = $sth->fetchrow;
+
+ # warn "change password for $borrowerid setting $password";
+ my $digest = md5_base64($password);
+ changepassword( $userid, $borrowerid, $digest );
}
-# INTERNAL AUTH
- my $sth=$dbh->prepare("select password,cardnumber from borrowers where userid=?");
+ # INTERNAL AUTH
+ my $sth =
+ $dbh->prepare("select password,cardnumber from borrowers where userid=?");
$sth->execute($userid);
- if ($sth->rows) {
- my ($md5password,$cardnumber) = $sth->fetchrow;
- if (md5_base64($password) eq $md5password) {
- return 1,$cardnumber;
+ if ( $sth->rows ) {
+ my ( $md5password, $cardnumber ) = $sth->fetchrow;
+ if ( md5_base64($password) eq $md5password ) {
+ return 1, $cardnumber;
}
}
- my $sth=$dbh->prepare("select password from borrowers where cardnumber=?");
+ $sth = $dbh->prepare("select password from borrowers where cardnumber=?");
$sth->execute($userid);
- if ($sth->rows) {
+ if ( $sth->rows ) {
my ($md5password) = $sth->fetchrow;
- if (md5_base64($password) eq $md5password) {
- return 1,$userid;
+ if ( md5_base64($password) eq $md5password ) {
+ return 1, $userid;
}
}
return 0;
}
sub getuserflags {
- my $cardnumber=shift;
- my $dbh=shift;
+ my $cardnumber = shift;
+ my $dbh = shift;
my $userflags;
- my $sth=$dbh->prepare("SELECT flags FROM borrowers WHERE cardnumber=?");
+ my $sth = $dbh->prepare("SELECT flags FROM borrowers WHERE cardnumber=?");
$sth->execute($cardnumber);
my ($flags) = $sth->fetchrow;
- $sth=$dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
+ $sth = $dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
$sth->execute;
- while (my ($bit, $flag, $defaulton) = $sth->fetchrow) {
- if (($flags & (2**$bit)) || $defaulton) {
- $userflags->{$flag}=1;
+
+ while ( my ( $bit, $flag, $defaulton ) = $sth->fetchrow ) {
+ if ( ( $flags & ( 2**$bit ) ) || $defaulton ) {
+ $userflags->{$flag} = 1;
}
}
return $userflags;
}
sub haspermission {
- my ($dbh, $userid, $flagsrequired) = @_;
- my $sth=$dbh->prepare("SELECT cardnumber FROM borrowers WHERE userid=?");
+ my ( $dbh, $userid, $flagsrequired ) = @_;
+ my $sth = $dbh->prepare("SELECT cardnumber FROM borrowers WHERE userid=?");
$sth->execute($userid);
my ($cardnumber) = $sth->fetchrow;
- ($cardnumber) || ($cardnumber=$userid);
- my $flags=getuserflags($cardnumber,$dbh);
+ ($cardnumber) || ( $cardnumber = $userid );
+ my $flags = getuserflags( $cardnumber, $dbh );
my $configfile;
- if ($userid eq C4::Context->config('user')) {
+ if ( $userid eq C4::Context->config('user') ) {
+
# Super User Account from /etc/koha.conf
- $flags->{'superlibrarian'}=1;
+ $flags->{'superlibrarian'} = 1;
}
- if ($userid eq 'demo' && C4::Context->config('demo')) {
+ if ( $userid eq 'demo' && C4::Context->config('demo') ) {
+
# Demo user that can do "anything" (demo=1 in /etc/koha.conf)
- $flags->{'superlibrarian'}=1;
+ $flags->{'superlibrarian'} = 1;
}
return $flags if $flags->{superlibrarian};
- foreach (keys %$flagsrequired) {
+ foreach ( keys %$flagsrequired ) {
return $flags if $flags->{$_};
}
return 0;
@@ -660,11 +764,11 @@
sub getborrowernumber {
my ($userid) = @_;
my $dbh = C4::Context->dbh;
- for my $field ('userid', 'cardnumber') {
- my $sth=$dbh->prepare
- ("select borrowernumber from borrowers where $field=?");
+ for my $field ( 'userid', 'cardnumber' ) {
+ my $sth =
+ $dbh->prepare("select borrowernumber from borrowers where $field=?");
$sth->execute($userid);
- if ($sth->rows) {
+ if ( $sth->rows ) {
my ($bnumber) = $sth->fetchrow;
return $bnumber;
}
Index: AuthoritiesMarc.pm
===================================================================
RCS file: /sources/koha/koha/C4/AuthoritiesMarc.pm,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -b -r1.37 -r1.38
--- AuthoritiesMarc.pm 20 Oct 2006 01:20:56 -0000 1.37
+++ AuthoritiesMarc.pm 9 Mar 2007 14:31:47 -0000 1.38
@@ -20,9 +20,10 @@
require Exporter;
use C4::Context;
use C4::Koha;
-use Encode;
+use MARC::Record;
use C4::Biblio;
-
+use C4::Search;
+#use ZOOM;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
@@ -33,22 +34,24 @@
&AUTHgettagslib
&AUTHfindsubfield
&AUTHfind_authtypecode
+
&AUTHaddauthority
&AUTHmodauthority
&AUTHdelauthority
&AUTHaddsubfield
-
+ &AUTHgetauthority
&AUTHfind_marc_from_kohafield
&AUTHgetauth_type
&AUTHcount_usage
&getsummary
&authoritysearch
&XMLgetauthority
- &XMLgetauthorityhash
- &XML_readline_withtags
+
+ &AUTHhtml2marc
+ &BuildUnimarcHierarchies
+ &BuildUnimarcHierarchy
&merge
- &FindDuplicateauth
- &ZEBRAdelauthority
+ &FindDuplicate
);
sub AUTHfind_marc_from_kohafield {
@@ -59,23 +62,24 @@
my $sth = $dbh->prepare("select tagfield,tagsubfield from auth_subfield_structure where kohafield= ? and authtypecode=? ");
$sth->execute($kohafield,$authtypecode);
my ($tagfield,$tagsubfield) = $sth->fetchrow;
+
return ($tagfield,$tagsubfield);
}
sub authoritysearch {
-## This routine requires rewrite--TG
- my ($dbh, $tags, $operator, $value, $offset,$length,$authtypecode,$dictionary) = @_;
-###Dictionary flag used to set what to show in summary;
+ my ($tags, $and_or, $excluding, $operator, $value, $offset,$length,$authtypecode,$sortby) = @_;
+ my $dbh=C4::Context->dbh;
my $query;
my $attr;
- my $server;
+ # the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
+ # the authtypecode. Then, search on $a of this tag_to_report
+ # also store main entry MARC tag, to extract it at end of search
my $mainentrytag;
- ##first set the authtype search and may be multiple authorities( linked authorities)
+ ##first set the authtype search and may be multiple authorities
my $n=0;
my @authtypecode;
my @auths=split / /,$authtypecode ;
- my ($attrfield)=MARCfind_attr_from_kohafield("authtypecode");
foreach my $auth (@auths){
- $query .=$attrfield." ".$auth." "; ##No truncation on authtype
+ $query .=" \@attr 1=Authority/format-id \@attr 5=100 ".$auth; ##No truncation on authtype
push @authtypecode ,$auth;
$n++;
}
@@ -88,48 +92,47 @@
my $q2;
for(my $i = 0 ; $i <= $#{$value} ; $i++)
{
-
if (@$value[$i]){
##If mainentry search $a tag
- if (@$tags[$i] eq "mainentry") {
- ($attr)=MARCfind_attr_from_kohafield("mainentry")." ";
+ if (@$tags[$i] eq "mainmainentry") {
+ $attr =" \@attr 1=Heading ";
+ }elsif (@$tags[$i] eq "mainentry") {
+ $attr =" \@attr 1=Heading-Entity ";
}else{
- ($attr) =MARCfind_attr_from_kohafield("allentry")." ";
+ $attr =" \@attr 1=Any ";
}
- if (@$operator[$i] eq 'phrase') {
- $attr.=" \@attr 4=1 \@attr 5=100 \@attr 6=3 ";##Phrase, No truncation,all of subfield field must match
-
+ if (@$operator[$i] eq 'is') {
+ $attr.=" \@attr 4=1 \@attr 5=100 ";##Phrase, No truncation,all of subfield field must match
+ }elsif (@$operator[$i] eq "="){
+ $attr.=" \@attr 4=107 "; #Number Exact match
+ }elsif (@$operator[$i] eq "start"){
+ $attr.=" \@attr 4=1 \@attr 5=1 ";#Phrase, Right truncated
} else {
-
- $attr .=" \@attr 4=6 \@attr 5=1 ";## Word list, right truncated, anywhere
+ $attr .=" \@attr 5=1 ";## Word list, right truncated, anywhere
}
-
-
$and .=" \@and " ;
$attr =$attr."\"".@$value[$i]."\"";
$q2 .=$attr;
$dosearch=1;
}#if value
-
- }## value loop
+ }
##Add how many queries generated
$query= $and.$query.$q2;
-#warn $query;
+$query=' @or @attr 7=1 @attr 1=Heading 0 '.$query if ($sortby eq "HeadingAsc");
+$query=' @or @attr 7=2 @attr 1=Heading 0 '.$query if ($sortby eq "HeadingDsc");
+warn $query;
$offset=0 unless $offset;
my $counter = $offset;
$length=10 unless $length;
my @oAuth;
my $i;
- $oAuth[0]=C4::Context->Zconn("authorityserver");
-my ($mainentry)=MARCfind_attr_from_kohafield("mainentry");
-my ($allentry)=MARCfind_attr_from_kohafield("allentry");
-
-$query="\@attr 2=102 \@or \@or ".$query." \@attr 7=1 ".$mainentry." 0 \@attr 7=1 ".$allentry." 1"; ## sort on mainfield and subfields
-
-
+$oAuth[0]=C4::Context->Zconn("authorityserver" , 1);
+my $Anewq= new ZOOM::Query::PQF($query,$oAuth[0]);
+# $Anewq->sortby("1=Heading i< 1=Heading-Entity i< ");
+# $Anewq->sortby("1=Heading i< 1=Heading-Entity i< ");
my $oAResult;
- $oAResult= $oAuth[0]->search_pqf($query) ;
+ $oAResult= $oAuth[0]->search($Anewq) ;
while (($i = ZOOM::event(\@oAuth)) != 0) {
my $ev = $oAuth[$i-1]->last_event();
# warn("Authority ", $i-1, ": event $ev (", ZOOM::event_str($ev), ")\n");
@@ -148,90 +151,152 @@
my @result = ();
my @finalresult = ();
+
if ($nbresults>0){
##Find authid and linkid fields
-
-
-while (($counter < $nbresults) && ($counter < ($offset + $length))) {
-##Here we have to extract MARC record and $authid from ZEBRA AUTHORITIES
-my $rec=$oAResult->record($counter);
-my $marcdata=$rec->raw();
-my $authrecord=Encode::decode("utf8",$marcdata);
-$authrecord=XML_xml2hash_onerecord($authrecord);
-my @linkids;
-my $separator=C4::Context->preference('authoritysep');
-my $linksummary=" ".$separator;
-my $authid=XML_readline_onerecord($authrecord,"authid","authorities");
-my @linkid=XML_readline_asarray($authrecord,"linkid","authorities");##May have many linked records
-
- foreach my $linkid (@linkid){
- my $linktype=AUTHfind_authtypecode($dbh,$linkid);
- my $linkrecord=XMLgetauthorityhash($dbh,$linkid);
- $linksummary.="<br> <a href='detail.pl?authid=$linkid'>".getsummary($dbh,$linkrecord,$linkid,$linktype).".</a>".$separator;
-
- }
-my $summary;
-unless ($dictionary){
- $summary=getsummary($dbh,$authrecord,$authid,$authtypecode);
-$summary="<a href='detail.pl?authid=$authid'>".$summary.".</a>";
- if ( $linksummary ne " ".$separator){
- $summary="<b>".$summary."</b>".$linksummary;
- }
-}else{
- $summary=getdictsummary($dbh,$authrecord,$authid,$authtypecode);
-}
-my $toggle;
- if ($counter % 2) {
- $toggle="#ffffcc";
- } else {
- $toggle="white";
- }
-my %newline;
- $newline{'toggle'}=$toggle;
+##we may be searching multiple authoritytypes.
+## FIXME this assumes that all authid and linkid fields are the same for all authority types
+# my ($authidfield,$authidsubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.authid",$authtypecode[0]);
+# my ($linkidfield,$linkidsubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.linkid",$authtypecode[0]);
+ while (($counter < $nbresults) && ($counter < ($offset + $length))) {
+
+ ##Here we have to extract MARC record and $authid from ZEBRA AUTHORITIES
+ my $rec=$oAResult->record($counter);
+ my $marcdata=$rec->raw();
+ my $authrecord;
+ my $linkid;
+ my @linkids;
+ my $separator=C4::Context->preference('authoritysep');
+ my $linksummary=" ".$separator;
+
+ $authrecord = MARC::File::USMARC::decode($marcdata);
+
+ my $authid=$authrecord->field('001')->data();
+ # if ($authrecord->field($linkidfield)){
+ # my @fields=$authrecord->field($linkidfield);
+ #
+ # # foreach my $field (@fields){
+ # # # $linkid=$field->subfield($linkidsubfield) ;
+ # # # if ($linkid){ ##There is a linked record add fields to produce summary
+ # # # my $linktype=AUTHfind_authtypecode($dbh,$linkid);
+ # # # my $linkrecord=AUTHgetauthority($dbh,$linkid);
+ # # # $linksummary.="<br> <a href='detail.pl?authid=$linkid'>".getsummary($dbh,$linkrecord,$linkid,$linktype).".</a>".$separator;
+ # # # }
+ # # }
+ # }#
+
+ my $summary=getsummary($authrecord,$authid,$authtypecode);
+# $summary="<a href='detail.pl?authid=$authid'>".$summary.".</a>" if ($intranet);
+# $summary="<a href='detail.pl?authid=$authid'>".$summary.".</a>" if ($intranet);
+ # if ($linkid && $linksummary ne " ".$separator){
+ # $summary="<b>".$summary."</b>".$linksummary;
+ # }
+ my $query_auth_tag = "SELECT auth_tag_to_report FROM auth_types WHERE authtypecode=?";
+ my $sth = $dbh->prepare($query_auth_tag);
+ $sth->execute($authtypecode);
+ my $auth_tag_to_report = $sth->fetchrow;
+ my %newline;
$newline{summary} = $summary;
$newline{authid} = $authid;
- $newline{linkid} = $linkid[0];
+ # $newline{linkid} = $linkid;
+ # $newline{reported_tag} = $reported_tag;
+ # $newline{used} =0;
+ # $newline{biblio_fields} = $tags_using_authtype;
$newline{even} = $counter % 2;
$counter++;
push @finalresult, \%newline;
}## while counter
-for (my $z=0; $z<$length; $z++){
- $finalresult[$z]{used}=AUTHcount_usage($finalresult[$z]{authid});
-
+ ###
+ for (my $z=0; $z<@finalresult; $z++){
+ my $count=AUTHcount_usage($finalresult[$z]{authid});
+ $finalresult[$z]{used}=$count;
}# all $z's
-
}## if nbresult
NOLUCK:
-$oAResult->destroy();
-$oAuth[0]->destroy();
+# $oAResult->destroy();
+# $oAuth[0]->destroy();
return (\@finalresult, $nbresults);
}
+# Creates the SQL Request
+
+sub create_request {
+ my ($dbh,$tags, $and_or, $operator, $value) = @_;
+
+ my $sql_tables; # will contain marc_subfield_table as m1,...
+ my $sql_where1; # will contain the "true" where
+ my $sql_where2 = "("; # will contain m1.authid=m2.authid
+ my $nb_active=0; # will contain the number of "active" entries. and entry is active is a value is provided.
+ my $nb_table=1; # will contain the number of table. ++ on each entry EXCEPT when an OR is provided.
+
+
+ for(my $i=0; $i<=@$value;$i++) {
+ if (@$value[$i]) {
+ $nb_active++;
+ if ($nb_active==1) {
+
+ $sql_tables = "auth_subfield_table as m$nb_table,";
+ $sql_where1 .= "( m$nb_table.subfieldvalue like '@$value[$i]' ";
+ if (@$tags[$i]) {
+ $sql_where1 .=" and concat(m$nb_table.tag,m$nb_table.subfieldcode) IN (@$tags[$i])";
+ }
+ $sql_where1.=")";
+ } else {
+
+
+
+
+ $nb_table++;
+
+ $sql_tables .= "auth_subfield_table as m$nb_table,";
+ $sql_where1 .= "@$and_or[$i] (m$nb_table.subfieldvalue like '@$value[$i]' ";
+ if (@$tags[$i]) {
+ $sql_where1 .=" and concat(m$nb_table.tag,m$nb_table.subfieldcode) IN (@$tags[$i])";
+ }
+ $sql_where1.=")";
+ $sql_where2.="m1.authid=m$nb_table.authid and ";
+
+
+ }
+ }
+ }
+
+ if($sql_where2 ne "(") # some datas added to sql_where2, processing
+ {
+ $sql_where2 = substr($sql_where2, 0, (length($sql_where2)-5)); # deletes the trailing ' and '
+ $sql_where2 .= ")";
+ }
+ else # no sql_where2 statement, deleting '('
+ {
+ $sql_where2 = "";
+ }
+ chop $sql_tables; # deletes the trailing ','
+
+ return ($sql_tables, $sql_where1, $sql_where2);
+}
sub AUTHcount_usage {
my ($authid) = @_;
### try ZOOM search here
-my @oConnection;
-$oConnection[0]=C4::Context->Zconn("biblioserver");
+my $oConnection=C4::Context->Zconn("biblioserver",1);
my $query;
-my ($attrfield)=MARCfind_attr_from_kohafield("authid");
-$query= $attrfield." ".$authid;
+$query= "an=".$authid;
-my $oResult = $oConnection[0]->search_pqf($query);
-my $event;
-my $i;
- while (($i = ZOOM::event(\@oConnection)) != 0) {
- $event = $oConnection[$i-1]->last_event();
- last if $event == ZOOM::Event::ZEND;
- }# while
-my $result=$oResult->size() ;
- return ($result);
+my $oResult = $oConnection->search(new ZOOM::Query::CCL2RPN( $query, $oConnection ));
+my $result;
+while ((my $i = ZOOM::event([ $oConnection ])) != 0) {
+ my $ev = $oConnection->last_event();
+ if ($ev == ZOOM::Event::ZEND) {
+ $result = $oResult->size();
+ }
+}
+return ($result);
}
@@ -266,17 +331,16 @@
while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) = $sth->fetchrow ) {
$res->{$tag}->{lib} = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
- $res->{$tab}->{tab} = ""; # XXX
+ $res->{$tag}->{tab} = " "; # XXX
$res->{$tag}->{mandatory} = $mandatory;
$res->{$tag}->{repeatable} = $repeatable;
}
- $sth= $dbh->prepare("select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,seealso,hidden,isurl,link from auth_subfield_structure where authtypecode=? order by tagfield,tagsubfield"
+ $sth= $dbh->prepare("select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,kohafield,seealso,hidden,isurl from auth_subfield_structure where authtypecode=? order by tagfield,tagsubfield"
);
$sth->execute($authtypecode);
my $subfield;
my $authorised_value;
- my $authtypecode;
my $value_builder;
my $kohafield;
my $seealso;
@@ -287,7 +351,7 @@
while (
( $tag, $subfield, $liblibrarian, , $libopac, $tab,
$mandatory, $repeatable, $authorised_value, $authtypecode,
- $value_builder, $seealso, $hidden,
+ $value_builder, $kohafield, $seealso, $hidden,
$isurl, $link )
= $sth->fetchrow
)
@@ -299,6 +363,7 @@
$res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
$res->{$tag}->{$subfield}->{authtypecode} = $authtypecode;
$res->{$tag}->{$subfield}->{value_builder} = $value_builder;
+ $res->{$tag}->{$subfield}->{kohafield} = $kohafield;
$res->{$tag}->{$subfield}->{seealso} = $seealso;
$res->{$tag}->{$subfield}->{hidden} = $hidden;
$res->{$tag}->{$subfield}->{isurl} = $isurl;
@@ -308,70 +373,135 @@
}
sub AUTHaddauthority {
-# pass the XML hash to this function, and it will create the records in the authority table
+# pass the MARC::Record to this function, and it will create the records in the authority table
my ($dbh,$record,$authid,$authtypecode) = @_;
+
+#my $leadercode=AUTHfind_leader($dbh,$authtypecode);
+my $leader=' a ';##Fixme correct leader as this one just adds utf8 to MARC21
+#substr($leader,8,1)=$leadercode;
+# $record->leader($leader);
+# my ($authfield,$authidsubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.authid",$authtypecode);
+# my ($authfield2,$authtypesubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.authtypecode",$authtypecode);
+# my ($linkidfield,$linkidsubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.linkid",$authtypecode);
+
# if authid empty => true add, find a new authid number
if (!$authid) {
my $sth=$dbh->prepare("select max(authid) from auth_header");
$sth->execute;
($authid)=$sth->fetchrow;
$authid=$authid+1;
- }
+ ##Insert the recordID in MARC record
+ ##Both authid and authtypecode is expected to be in the same field. Modify if other requirements arise
+ $record->add_fields('001',$authid) unless $record->field('001');
+ $record->add_fields('152','','','b'=>$authtypecode) unless $record->field('152');
+# $record->add_fields('100','','','b'=>$authtypecode);
+ warn $record->as_formatted;
+ $dbh->do("lock tables auth_header WRITE");
+ $sth=$dbh->prepare("insert into auth_header (authid,datecreated,authtypecode,marc) values (?,now(),?,?)");
+ $sth->execute($authid,$authtypecode,$record->as_usmarc);
+ $sth->finish;
-##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);
+ }else{
+ ##Modified record reinsertid
+# my $idfield=$record->field('001');
+# $record->delete_field($idfield);
+ $record->add_fields('001',$authid) unless ($record->field('001'));
+ $record->add_fields('152','','','b'=>$authtypecode) unless ($record->field('152'));
+# $record->add_fields($authfield,$authid);
+# $record->add_fields($authfield2,'','',$authtypesubfield=>$authtypecode);
+ warn $record->as_formatted;
+ $dbh->do("lock tables auth_header WRITE");
+ my $sth=$dbh->prepare("update auth_header set marc=? where authid=?");
+ $sth->execute($record->as_usmarc,$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");
- foreach my $linkid (@linkids){
- ##Modify the record of linked
- AUTHaddlink($dbh,$linkid,$authid);
}
-return ($authid);
+ $dbh->do("unlock tables");
+ zebraop($dbh,$authid,'specialUpdate',"authorityserver");
+
+# if ($record->field($linkidfield)){
+# my @fields=$record->field($linkidfield);
+#
+# foreach my $field (@fields){
+# my $linkid=$field->subfield($linkidsubfield) ;
+# if ($linkid){
+# ##Modify the record of linked
+# AUTHaddlink($dbh,$linkid,$authid);
+# }
+# }
+# }
+ return ($authid);
}
sub AUTHaddlink{
my ($dbh,$linkid,$authid)=@_;
-my $record=XMLgetauthorityhash($dbh,$linkid);
+my $record=AUTHgetauthority($dbh,$linkid);
my $authtypecode=AUTHfind_authtypecode($dbh,$linkid);
#warn "adding l:$linkid,a:$authid,auth:$authtypecode";
-XML_writeline($record,"linkid",$authid,"authorities");
-my $xml=XML_hash2xml($record);
-$dbh->do("lock tables header WRITE");
- my $sth=$dbh->prepare("update auth_header set marcxml=? where authid=?");
- $sth->execute($xml,$linkid);
+$record=AUTH2marcOnefieldlink($dbh,$record,"auth_header.linkid",$authid,$authtypecode);
+$dbh->do("lock tables auth_header WRITE");
+ my $sth=$dbh->prepare("update auth_header set marc=? where authid=?");
+ $sth->execute($record->as_usmarc,$linkid);
$sth->finish;
$dbh->do("unlock tables");
- ZEBRAop($dbh,$linkid,'specialUpdate',"authorityserver");
+ zebraop($dbh,$linkid,'specialUpdate',"authorityserver");
}
-
+sub AUTH2marcOnefieldlink {
+ my ( $dbh, $record, $kohafieldname, $newvalue,$authtypecode ) = @_;
+my $sth = $dbh->prepare(
+"select tagfield,tagsubfield from auth_subfield_structure where authtypecode=? and kohafield=?"
+ );
+ $sth->execute($authtypecode,$kohafieldname);
+my ($tagfield,$tagsubfield)=$sth->fetchrow;
+ $record->add_fields( $tagfield, " ", " ", $tagsubfield => $newvalue );
+ return $record;
+}
sub XMLgetauthority {
+
# Returns MARC::XML of the authority passed in parameter.
my ( $dbh, $authid ) = @_;
- my $sth = $dbh->prepare("select marcxml from auth_header where authid=? " );
+
+
+ my $sth =
+ $dbh->prepare("select marc from auth_header where authid=? " );
+
$sth->execute($authid);
- my ($marcxml)=$sth->fetchrow;
- $marcxml=Encode::decode('utf8',$marcxml);
- return ($marcxml);
-}
+ my ($marc)=$sth->fetchrow;
+$marc=MARC::File::USMARC::decode($marc);
+ my $marcxml=$marc->as_xml_record();
+ return $marcxml;
-sub XMLgetauthorityhash {
-## Utility to return hashed MARCXML
-my ($dbh,$authid)=@_;
-my $xml=XMLgetauthority($dbh,$authid);
-my $xmlhash=XML_xml2hash_onerecord($xml);
-return $xmlhash;
}
+sub AUTHfind_leader{
+##Hard coded for NEU auth types
+my($dbh,$authtypecode)=@_;
+my $leadercode;
+if ($authtypecode eq "AUTH"){
+$leadercode="a";
+}elsif ($authtypecode eq "ESUB"){
+$leadercode="b";
+}elsif ($authtypecode eq "TSUB"){
+$leadercode="c";
+}else{
+$leadercode=" ";
+}
+return $leadercode;
+}
+
+sub AUTHgetauthority {
+# Returns MARC::Record of the biblio passed in parameter.
+ my ($dbh,$authid)=@_;
+my $sth=$dbh->prepare("select marc from auth_header where authid=?");
+ $sth->execute($authid);
+ my ($marc) = $sth->fetchrow;
+my $record=MARC::File::USMARC::decode($marc);
+
+ return ($record);
+}
sub AUTHgetauth_type {
my ($authtypecode) = @_;
@@ -380,52 +510,49 @@
$sth->execute($authtypecode);
return $sth->fetchrow_hashref;
}
-
-
sub AUTHmodauthority {
-## $record is expected to be an xmlhash
- my ($dbh,$authid,$record,$authtypecode)=@_;
- my ($oldrecord)=&XMLgetauthorityhash($dbh,$authid);
-### This equality is very dodgy ,It porobaby wont work
+
+ my ($dbh,$authid,$record,$authtypecode,$merge)=@_;
+ my ($oldrecord)=&AUTHgetauthority($dbh,$authid);
if ($oldrecord eq $record) {
- return $authid;
+ return;
}
-##
-my $sth=$dbh->prepare("update auth_header set marcxml=? where authid=?");
-# find if linked records exist and delete the link in them
-my @linkids=XML_readline_asarray($oldrecord,"linkid","authorities");
-
- foreach my $linkid (@linkids){
+my $sth=$dbh->prepare("update auth_header set marc=? where authid=?");
+#warn find if linked records exist and delete them
+my($linkidfield,$linkidsubfield)=AUTHfind_marc_from_kohafield($dbh,"auth_header.linkid",$authtypecode);
+
+if ($oldrecord->field($linkidfield)){
+my @fields=$oldrecord->field($linkidfield);
+ foreach my $field (@fields){
+my $linkid=$field->subfield($linkidsubfield) ;
+ if ($linkid){
##Modify the record of linked
- my $linkrecord=XMLgetauthorityhash($dbh,$linkid);
+ my $linkrecord=AUTHgetauthority($dbh,$linkid);
my $linktypecode=AUTHfind_authtypecode($dbh,$linkid);
- my @linkfields=XML_readline_asarray($linkrecord,"linkid","authorities");
- my $updated;
+ my ( $linkidfield2,$linkidsubfield2)=AUTHfind_marc_from_kohafield($dbh,"auth_header.linkid",$linktypecode);
+ my @linkfields=$linkrecord->field($linkidfield2);
foreach my $linkfield (@linkfields){
- if ($linkfield eq $authid){
- XML_writeline_id($linkrecord,"linkid",$linkfield,"","authorities");
- $updated=1;
+ if ($linkfield->subfield($linkidsubfield2) eq $authid){
+ $linkrecord->delete_field($linkfield);
+ $sth->execute($linkrecord->as_usmarc,$linkid);
+ zebraop($dbh,$linkid,'specialUpdate',"authorityserver");
}
}#foreach linkfield
- my $linkedxml=XML_hash2xml($linkrecord);
- if ($updated==1){
- $sth->execute($linkedxml,$linkid);
- ZEBRAop($dbh,$linkid,'specialUpdate',"authorityserver");
}
-
}#foreach linkid
-
+}
#Now rewrite the $record to table with an add
$authid=AUTHaddauthority($dbh,$record,$authid,$authtypecode);
-### If a library thinks that updating all biblios is a long process and wishes to leave that to a cron job to use merge_authotities.pl
+### If a library thinks that updating all biblios is a long process and wishes to leave that to a cron job to use merge_authotities.p
### they should have a system preference "dontmerge=1" otherwise by default biblios will be updated
+### the $merge flag is now depreceated and will be removed at code cleaning
if (C4::Context->preference('dontmerge') ){
# save the file in localfile/modified_authorities
my $cgidir = C4::Context->intranetdir ."/cgi-bin";
- unless (opendir(DIR, "$cgidir")) {
+ unless (opendir(DIR,"$cgidir")) {
$cgidir = C4::Context->intranetdir."/";
}
@@ -433,7 +560,7 @@
open AUTH, "> $filename";
print AUTH $authid;
close AUTH;
-}else{
+} else {
&merge($dbh,$authid,$record,$authid,$record);
}
return $authid;
@@ -441,401 +568,374 @@
sub AUTHdelauthority {
my ($dbh,$authid,$keep_biblio) = @_;
-
# if the keep_biblio is set to 1, then authority entries in biblio are preserved.
-# FIXME : delete or not in biblio tables (depending on $keep_biblio flag) is not implemented
-ZEBRAop($dbh,$authid,"recordDelete","authorityserver");
-}
-sub ZEBRAdelauthority {
-my ($dbh,$authid)=@_;
+zebraop($dbh,$authid,"recordDelete","authorityserver");
$dbh->do("delete from auth_header where authid=$authid") ;
+
+# FIXME : delete or not in biblio tables (depending on $keep_biblio flag)
}
-sub AUTHfind_authtypecode {
- my ($dbh,$authid) = @_;
- my $sth = $dbh->prepare("select authtypecode from auth_header where authid=?");
- $sth->execute($authid);
- my ($authtypecode) = $sth->fetchrow;
- return $authtypecode;
+sub AUTHhtml2marc {
+ my ($dbh,$rtags,$rsubfields,$rvalues,%indicators) = @_;
+ my $prevtag = -1;
+ my $record = MARC::Record->new();
+#---- TODO : the leader is missing
+
+# my %subfieldlist=();
+ my $prevvalue; # if tag <10
+ my $field; # if tag >=10
+ for (my $i=0; $i< @$rtags; $i++) {
+ # rebuild MARC::Record
+ if (@$rtags[$i] ne $prevtag) {
+ if ($prevtag < 10) {
+ if ($prevvalue) {
+ $record->add_fields((sprintf "%03s",$prevtag),$prevvalue);
+ }
+ } else {
+ if ($field) {
+ $record->add_fields($field);
+ }
+ }
+ $indicators{@$rtags[$i]}.=' ';
+ if (@$rtags[$i] <10) {
+ $prevvalue= @$rvalues[$i];
+ undef $field;
+ } else {
+ undef $prevvalue;
+ $field = MARC::Field->new( (sprintf "%03s",@$rtags[$i]), substr($indicators{@$rtags[$i]},0,1),substr($indicators{@$rtags[$i]},1,1), @$rsubfields[$i] => @$rvalues[$i]);
+ }
+ $prevtag = @$rtags[$i];
+ } else {
+ if (@$rtags[$i] <10) {
+ $prevvalue=@$rvalues[$i];
+ } else {
+ if (length(@$rvalues[$i])>0) {
+ $field->add_subfields(@$rsubfields[$i] => @$rvalues[$i]);
+ }
+ }
+ $prevtag= @$rtags[$i];
+ }
+ }
+ # the last has not been included inside the loop... do it now !
+ $record->add_fields($field) if $field;
+ return $record;
}
-sub FindDuplicateauth {
-### Should receive an xmlhash
+
+sub FindDuplicate {
+
my ($record,$authtypecode)=@_;
+# warn "IN for ".$record->as_formatted;
my $dbh = C4::Context->dbh;
+# warn "".$record->as_formatted;
my $sth = $dbh->prepare("select auth_tag_to_report from auth_types where authtypecode=?");
$sth->execute($authtypecode);
my ($auth_tag_to_report) = $sth->fetchrow;
$sth->finish;
+# warn "record :".$record->as_formatted." authtattoreport :$auth_tag_to_report";
# build a request for authoritysearch
- my (@tags, @and_or, @excluding, @operator, @value, $offset, $length);
-
-# if ($record->field($auth_tag_to_report)) {
- push @tags, $auth_tag_to_report;
- push @operator, "all";
- @value, XML_readline_asarray($record,"","",$auth_tag_to_report);
-# }
-
- my ($finalresult,$nbresult) = authoritysearch($dbh,\@tags,\@and_or,\@excluding,\@operator,\@value,0,10,$authtypecode);
+ my $query='at='.$authtypecode.' ';
+ map {$query.= " and he=\"".$_->[1]."\"" if ($_->[0]=~/[A-z]/)} $record->field($auth_tag_to_report)->subfields();
+ my ($error,$results)=SimpleSearch($query,"authorityserver");
# there is at least 1 result => return the 1st one
- if ($nbresult>0) {
- return @$finalresult[0]->{authid},@$finalresult[0]->{summary};
+ if (@$results>0) {
+ my $marcrecord = MARC::File::USMARC::decode($results->[0]);
+ return $marcrecord->field('001')->data,getsummary($marcrecord,$marcrecord->field('001')->data,$authtypecode);
}
# no result, returns nothing
return;
}
sub getsummary{
-## give this an XMLhash record to return summary
-my ($dbh,$record,$authid,$authtypecode)=@_;
+## give this a Marc record to return summary
+my ($record,$authid,$authtypecode)=@_;
+
+my $dbh=C4::Context->dbh;
+# my $authtypecode = AUTHfind_authtypecode($dbh,$authid);
my $authref = getauthtype($authtypecode);
my $summary = $authref->{summary};
+ my @fields = $record->fields();
+# chop $tags_using_authtype; # FIXME: why commented out?
+ my $reported_tag;
+
# if the library has a summary defined, use it. Otherwise, build a standard one
if ($summary) {
- my $fields = $record->{'datafield'};
- foreach my $field (@$fields) {
- my $tag = $field->{'tag'};
- if ($tag<10) {
- my $tagvalue = XML_readline_onerecord($record,"","",$field->{tag});
+ my @fields = $record->fields();
+# $reported_tag = '$9'.$result[$counter];
+ foreach my $field (@fields) {
+ my $tag = $field->tag();
+ my $tagvalue = $field->as_string();
$summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
+ if ($tag<10) {
+ if ($tag eq '001') {
+ $reported_tag.='$3'.$field->data();
+ }
+
} else {
- my @subf = XML_readline_withtags($record,"","",$tag);
+ my @subf = $field->subfields;
for my $i (0..$#subf) {
my $subfieldcode = $subf[$i][0];
my $subfieldvalue = $subf[$i][1];
my $tagsubf = $tag.$subfieldcode;
$summary =~ s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
- }## each subf
- }#tag >10
- }##each field
+# if ($tag eq $auth_tag_to_report) {
+# $reported_tag.='$'.$subfieldcode.$subfieldvalue;
+# }
+ }
+ }
+ }
$summary =~ s/\[(.*?)]//g;
$summary =~ s/\n/<br>/g;
} else {
-## $summary did not exist create a standard summary
my $heading; # = $authref->{summary};
my $altheading;
my $seeheading;
my $see;
- my $fields = $record->{datafield};
+ my @fields = $record->fields();
if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
# construct UNIMARC summary, that is quite different from MARC21 one
- foreach my $field (@$fields) {
# accepted form
- if ($field->{tag} = ~/'2..'/) {
- foreach my $subfield ("a".."z"){
- ## Fixme-- if UNICODE uses numeric subfields as well add them
- $heading.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
+ foreach my $field ($record->field('2..')) {
+ $heading.= $field->as_string();
}
- }##tag 2..
# rejected form(s)
- if ($field->{tag} = ~/'4..'/) {
- my $value;
- foreach my $subfield ("a".."z"){
- ## Fixme-- if UNICODE uses numeric subfields as well add them
- $value.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
- }
- $summary.= " <i>".$value."</i><br/>";
+ foreach my $field ($record->field('4..')) {
+ $summary.= " <i>".$field->as_string()."</i><br/>";
$summary.= " <i>see:</i> ".$heading."<br/>";
- }##tag 4..
- # see :
- if ($field->{tag} = ~/'5..'/) {
- my $value;
- foreach my $subfield ("a".."z"){
- ## Fixme-- if UNICODE uses numeric subfields as well add them
- $value.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
}
- $summary.= " <i>".$value."</i><br/>";
+ # see :
+ foreach my $field ($record->field('5..')) {
+ $summary.= " <i>".$field->as_string()."</i><br/>";
$summary.= " <i>see:</i> ".$heading."<br/>";
- }# tag 5..
- # // form
- if ($field->{tag} = ~/'7..'/) {
- my $value;
- foreach my $subfield ("a".."z"){
- ## Fixme-- if UNICODE uses numeric subfields as well add them
- $value.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
}
- $seeheading.= " <i>see also:</i> ".$value."<br />";
- $altheading.= " ".$value."<br />";
+ # // form
+ foreach my $field ($record->field('7..')) {
+ $seeheading.= " <i>see also:</i> ".$field->as_string()."<br />";
+ $altheading.= " ".$field->as_string()."<br />";
$altheading.= " <i>see also:</i> ".$heading."<br />";
- }# tag 7..
- }## Foreach fields
+ }
$summary = "<b>".$heading."</b><br />".$seeheading.$altheading.$summary;
} else {
# construct MARC21 summary
- foreach my $field (@$fields) {
- my $tag="1..";
- if($field->{tag} =~ /^$tag/) {
- if ($field->{tag} eq '150') {
- my $value;
- foreach my $subfield ("a".."z"){
- $value=XML_readline_onerecord($record,"","","150",$subfield);
- $heading.="\$".$subfield.$value if $value;
- }
- }else{
- foreach my $subfield ("a".."z"){
- $heading.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
- }
- }### tag 150 or else
- }##tag 1..
- my $tag="4..";
- if($field->{tag} =~ /^$tag/) {
- foreach my $subfield ("a".."z"){
- $seeheading.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
+ foreach my $field ($record->field('1..')) {
+ if ($record->field('100')) {
+ $heading.= $field->as_string('abcdefghjklmnopqrstvxyz68');
+ } elsif ($record->field('110')) {
+ $heading.= $field->as_string('abcdefghklmnoprstvxyz68');
+ } elsif ($record->field('111')) {
+ $heading.= $field->as_string('acdefghklnpqstvxyz68');
+ } elsif ($record->field('130')) {
+ $heading.= $field->as_string('adfghklmnoprstvxyz68');
+ } elsif ($record->field('148')) {
+ $heading.= $field->as_string('abvxyz68');
+ } elsif ($record->field('150')) {
+ # $heading.= $field->as_string('abvxyz68');
+ $heading.= $field->as_formatted();
+ my $tag=$field->tag();
+ $heading=~s /^$tag//g;
+ $heading =~s /\_/\$/g;
+ } elsif ($record->field('151')) {
+ $heading.= $field->as_string('avxyz68');
+ } elsif ($record->field('155')) {
+ $heading.= $field->as_string('abvxyz68');
+ } elsif ($record->field('180')) {
+ $heading.= $field->as_string('vxyz68');
+ } elsif ($record->field('181')) {
+ $heading.= $field->as_string('vxyz68');
+ } elsif ($record->field('182')) {
+ $heading.= $field->as_string('vxyz68');
+ } elsif ($record->field('185')) {
+ $heading.= $field->as_string('vxyz68');
+ } else {
+ $heading.= $field->as_string();
}
- $seeheading.= " ".$seeheading."<br />";
+ } #See From
+ foreach my $field ($record->field('4..')) {
+ $seeheading.= " ".$field->as_string()."<br />";
$seeheading.= " <i>see:</i> ".$seeheading."<br />";
- } #tag 4..
- my $tag="5..";
- if($field->{tag} =~ /^$tag/) {
- my $value;
- foreach my $subfield ("a".."z"){
- $value.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
- }
- $seeheading.= " <i>see also:</i> ".$value."<br />";
- $altheading.= " ".$value."<br />";
+ } #See Also
+ foreach my $field ($record->field('5..')) {
+ $altheading.= " <i>see also:</i> ".$field->as_string()."<br />";
+ $altheading.= " ".$field->as_string()."<br />";
$altheading.= " <i>see also:</i> ".$altheading."<br />";
- }#tag 5..
-
- }##for each field
+ }
$summary.=$heading.$seeheading.$altheading;
- }##USMARC vs UNIMARC
- }###Summary exists or not
+ }
+ }
return $summary;
}
-sub getdictsummary{
-## give this a XML record to return a brief summary
-my ($dbh,$record,$authid,$authtypecode)=@_;
- my $authref = getauthtype($authtypecode);
- my $summary = $authref->{summary};
- my $fields = $record->{'datafield'};
- # if the library has a summary defined, use it. Otherwise, build a standard one
- if ($summary) {
- foreach my $field (@$fields) {
- my $tag = $field->{'tag'};
- if ($tag<10) {
- my $tagvalue = XML_readline_onerecord($record,"","",$field->{tag});
- $summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
+sub BuildUnimarcHierarchies{
+ my $authid = shift @_;
+# warn "authid : $authid";
+ my $force = shift @_;
+ my @globalresult;
+ my $dbh=C4::Context->dbh;
+ my $hierarchies;
+ my $data = AUTHgetheader($dbh,$authid);
+
+ if ($data->{'authtrees'} and not $force){
+ return $data->{'authtrees'};
+ } elsif ($data->{'authtrees'}){
+ $hierarchies=$data->{'authtrees'};
} else {
- my @subf = XML_readline_withtags($record,"","",$tag);
- for my $i (0..$#subf) {
- my $subfieldcode = $subf[$i][0];
- my $subfieldvalue = $subf[$i][1];
- my $tagsubf = $tag.$subfieldcode;
- $summary =~ s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
- }## each subf
- }#tag >10
- }##each field
- $summary =~ s/\[(.*?)]//g;
- $summary =~ s/\n/<br>/g;
+ my $record = AUTHgetauthority($dbh,$authid);
+ my $found;
+ foreach my $field ($record->field('550')){
+ if ($field->subfield('5') && $field->subfield('5') eq 'g'){
+ my $parentrecord = AUTHgetauthority($dbh,$field->subfield('3'));
+ my $localresult=$hierarchies;
+ my $trees;
+ $trees = BuildUnimarcHierarchies($field->subfield('3'));
+ my @trees;
+ if ($trees=~/;/){
+ @trees = split(/;/,$trees);
} else {
- my $heading; # = $authref->{summary};
- my $altheading;
- my $seeheading;
- my $see;
- my $fields = $record->{datafield};
- if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
- # construct UNIMARC summary, that is quite different from MARC21 one
- foreach my $field (@$fields) {
- # accepted form
- if ($field->{tag} = ~/'2..'/) {
- foreach my $subfield ("a".."z"){
- ## Fixme-- if UNICODE uses numeric subfields as well add them
- $heading.=XML_readline_onerecord($record,"","",$field->{tag},$subfield);
+ push @trees, $trees;
}
- }##tag 2..
+ foreach (@trees){
+ $_.= ",$authid";
}
- $summary = $heading;
- } else {
- # construct MARC21 summary
- foreach my $field (@$fields) {
- my $tag="1..";
- if($field->{tag} =~ /^$tag/) {
- $heading.= XML_readline_onerecord($record,"","",$field->{tag},"a");
- }
- } #each fieldd
-
- $summary=$heading;
- }# USMARC vs UNIMARC
- }### Summary exists
-return $summary;
+ @globalresult = (@globalresult, at trees);
+ $found=1;
+ }
+ $hierarchies=join(";", at globalresult);
+ }
+ #Unless there is no ancestor, I am alone.
+ $hierarchies="$authid" unless ($hierarchies);
+ }
+ AUTHsavetrees($authid,$hierarchies);
+ return $hierarchies;
+}
+
+sub BuildUnimarcHierarchy{
+ my $record = shift @_;
+ my $class = shift @_;
+ my $authid_constructed = shift @_;
+ my $authid=$record->subfield('250','3');
+ my %cell;
+ my $parents=""; my $children="";
+ my (@loopparents, at loopchildren);
+ foreach my $field ($record->field('550')){
+ if ($field->subfield('5') && $field->subfield('a')){
+ if ($field->subfield('5') eq 'h'){
+ push @loopchildren, { "childauthid"=>$field->subfield('3'),"childvalue"=>$field->subfield('a')};
+ }elsif ($field->subfield('5') eq 'g'){
+ push @loopparents, { "parentauthid"=>$field->subfield('3'),"parentvalue"=>$field->subfield('a')};
+ }
+ # brothers could get in there with an else
+ }
+ }
+ $cell{"ifparents"}=1 if (scalar(@loopparents)>0);
+ $cell{"ifchildren"}=1 if (scalar(@loopchildren)>0);
+ $cell{"loopparents"}=\@loopparents if (scalar(@loopparents)>0);
+ $cell{"loopchildren"}=\@loopchildren if (scalar(@loopchildren)>0);
+ $cell{"class"}=$class;
+ $cell{"loopauthid"}=$authid;
+ $cell{"current_value"} =1 if $authid eq $authid_constructed;
+ $cell{"value"}=$record->subfield('250',"a");
+ return \%cell;
+}
+
+sub AUTHgetheader{
+ my $authid = shift @_;
+ my $sql= "SELECT * from auth_header WHERE authid = ?";
+ my $dbh=C4::Context->dbh;
+ my $rq= $dbh->prepare($sql);
+ $rq->execute($authid);
+ my $data= $rq->fetchrow_hashref;
+ return $data;
+}
+
+sub AUTHsavetrees{
+ my $authid = shift @_;
+ my $trees = shift @_;
+ my $sql= "UPDATE IGNORE auth_header set authtrees=? WHERE authid = ?";
+ my $dbh=C4::Context->dbh;
+ my $rq= $dbh->prepare($sql);
+ $rq->execute($trees,$authid);
}
sub merge {
-##mergefrom is authid MARCfrom is marcxml hash of authority
-### mergeto ditto
my ($dbh,$mergefrom,$MARCfrom,$mergeto,$MARCto) = @_;
- return unless (defined $MARCfrom);
- return unless (defined $MARCto);
my $authtypecodefrom = AUTHfind_authtypecode($dbh,$mergefrom);
my $authtypecodeto = AUTHfind_authtypecode($dbh,$mergeto);
# return if authority does not exist
+ my @X = $MARCfrom->fields();
+ return if $#X == -1;
+ @X = $MARCto->fields();
+ return if $#X == -1;
+
# search the tag to report
my $sth = $dbh->prepare("select auth_tag_to_report from auth_types where authtypecode=?");
$sth->execute($authtypecodefrom);
my ($auth_tag_to_report) = $sth->fetchrow;
+
my @record_to;
+ @record_to = $MARCto->field($auth_tag_to_report)->subfields() if $MARCto->field($auth_tag_to_report);
+ my @record_from;
+ @record_from = $MARCfrom->field($auth_tag_to_report)->subfields() if $MARCfrom->field($auth_tag_to_report);
+
# search all biblio tags using this authority.
- $sth = $dbh->prepare("select distinct tagfield from biblios_subfield_structure where authtypecode=? ");
+ $sth = $dbh->prepare("select distinct tagfield from marc_subfield_structure where authtypecode=?");
$sth->execute($authtypecodefrom);
my @tags_using_authtype;
while (my ($tagfield) = $sth->fetchrow) {
- push @tags_using_authtype,$tagfield ;
+ push @tags_using_authtype,$tagfield."9" ;
}
-## The subfield for linking authorities is stored in koha_attr named auth_biblio_link_subf
-## This way we may use whichever subfield we want without harcoding 9 in
-my ($dummyfield,$tagsubfield)=MARCfind_marc_from_kohafield("auth_biblio_link_subf","biblios");
+
# now, find every biblio using this authority
### try ZOOM search here
-my @oConnection;
- $oConnection[0]=C4::Context->Zconn("biblioserver");
-##$oConnection[0]->option(elementSetName=>"biblios"); ## Needs a fix
+my $oConnection=C4::Context->Zconn("biblioserver");
my $query;
-my ($attr2)=MARCfind_attr_from_kohafield("authid");
-my $attrfield.=$attr2;
-$query= $attrfield." ".$mergefrom;
-my ($event,$i);
-my $oResult = $oConnection[0]->search_pqf($query);
- while (($i = ZOOM::event(\@oConnection)) != 0) {
- $event = $oConnection[$i-1]->last_event();
- last if $event == ZOOM::Event::ZEND;
- }# while event
-my $count=$oResult->size();
+$query= "an= ".$mergefrom;
+my $oResult = $oConnection->search(new ZOOM::Query::CCL2RPN( $query, $oConnection ));
+my $count=$oResult->size() if ($oResult);
my @reccache;
my $z=0;
while ( $z<$count ) {
my $rec;
$rec=$oResult->record($z);
my $marcdata = $rec->raw();
-my $koharecord=Encode::decode("utf8",$marcdata);
-$koharecord=XML_xml2hash($koharecord);
- my ( $xmlrecord, @itemsrecord) = XML_separate($koharecord);
-
-push @reccache, $xmlrecord;
+push @reccache, $marcdata;
$z++;
}
$oResult->destroy();
-$oConnection[0]->destroy();
- foreach my $xmlhash (@reccache){
- my $update;
+foreach my $marc(@reccache){
+
+my $update;
+ my $marcrecord;
+ $marcrecord = MARC::File::USMARC::decode($marc);
foreach my $tagfield (@tags_using_authtype){
+ $tagfield=substr($tagfield,0,3);
+ my @tags = $marcrecord->field($tagfield);
+ foreach my $tag (@tags){
+ my $tagsubs=$tag->subfield("9");
+#warn "$tagfield:$tagsubs:$mergefrom";
+ if ($tagsubs== $mergefrom) {
- ###Change the authid in biblio
- $xmlhash=XML_writeline_id($xmlhash,$mergefrom,$mergeto,$tagfield,$tagsubfield);
- ### delete all subfields of bibliorecord
- $xmlhash=XML_delete_withid($xmlhash,$mergeto,$tagfield,$tagsubfield);
- ####Read all the data in from authrecord
- my @record_to=XML_readline_withtags($MARCto,"","",$auth_tag_to_report);
- ##Write the data to biblio
+ $tag->update("9" =>$mergeto);
foreach my $subfield (@record_to) {
- ## Replace the data in MARCXML with the new matching authid
- XML_writeline_withid($xmlhash,$tagsubfield,$mergeto,$subfield->[1],$tagfield,$subfield->[0]);
+# warn "$subfield,$subfield->[0],$subfield->[1]";
+ $tag->update($subfield->[0] =>$subfield->[1]);
+ }#for $subfield
+ }
+ $marcrecord->delete_field($tag);
+ $marcrecord->add_fields($tag);
$update=1;
- }#foreach $subfield
+ }#for each tag
}#foreach tagfield
+ my $oldbiblio = MARCmarc2koha($dbh,$marcrecord,"") ;
if ($update==1){
- my $biblionumber=XML_readline_onerecord($xmlhash,"biblionumber","biblios");
- my $frameworkcode=MARCfind_frameworkcode($dbh,$biblionumber);
- NEWmodbiblio($dbh,$biblionumber,$xmlhash,$frameworkcode) ;
+ # FIXME : this NEWmodbiblio does not exist anymore...
+ &ModBiblio($marcrecord,$oldbiblio->{'biblionumber'},MARCfind_frameworkcode($oldbiblio->{'biblionumber'})) ;
}
- }#foreach $xmlhash
+}#foreach $marc
}#sub
-
-sub XML_writeline_withid{
-## Only used in authorities to update biblios with matching authids
-my ($xml,$idsubf,$id,$newvalue,$tag,$subf)=@_;
-my $biblio=$xml->{'datafield'};
-my $updated=0;
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- my @subfields=$data->{'subfield'};
- foreach my $subfield ( @subfields){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $idsubf && $code->{'content'} eq $id){
- ###This is the correct tag -- Now reiterate and update
- my @newsubs;
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf ){
- $code->{'content'}=$newvalue;
- $updated=1;
- }
- push @newsubs, $code;
- }## each code updated
- if (!$updated){
- ##Create the subfield if it did not exist
- push @newsubs,{code=>$subf,content=>$newvalue};
- $data->{subfield}= \@newsubs;
- $updated=1;
- }### created
- }### correct tag with id
- }#each code
- }##each subfield
- }# tag match
- }## each datafield
- }### tag >9
-return $xml;
-}
-sub XML_delete_withid{
-## Currently only usedin authorities
-### deletes all the subfields of a matching authid
-my ($xml,$id,$tag,$idsubf)=@_;
-my $biblio=$xml->{'datafield'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- my @subfields=$data->{'subfield'};
- foreach my $subfield ( @subfields){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $idsubf && $code->{'content'} eq $id){
- ###This is the correct tag -- Now reiterate and delete all but id subfield
- foreach my $code ( @$subfield){
- if ($code->{'code'} ne $idsubf ){
- $code->{'content'}="";
- }
- }## each code deleted
- }### correct tag with id
- }#each code
- }## each subfield
- }## tag matches
- }## each datafield
- }# tag >9
-return $xml;
-}
-
-sub XML_readline_withtags {
-my ($xml,$kohafield,$recordtype,$tag,$subf)=@_;
-#$xml represents one record of MARCXML as perlhashed
-## returns an array of read fields--useful for reading repeated fields
-### $recordtype is needed for mapping the correct field if supplied
-### If only $tag is given reads the whole tag
-###Returns subfieldcodes as well
-my @value;
- ($tag,$subf)=MARCfind_marc_from_kohafield($kohafield,$recordtype) if $kohafield;
-if ($tag){
-### Only datafields are read
-my $biblio=$xml->{'datafield'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- foreach my $subfield ( $data->{'subfield'}){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf || !$subf){
- push @value,[$code->{'code'},$code->{'content'}];
- }
- }# each code
- }# each subfield
- }### tag found
- }## each tag
- }##tag >9
-}## if tag
-return @value;
-}
-
END { } # module clean-up code here (global destructor)
=back
@@ -848,10 +948,81 @@
=cut
-# $Id: AuthoritiesMarc.pm,v 1.37 2006/10/20 01:20:56 tgarip1957 Exp $
-
-# Revision 1.30 2006/09/06 16:21:03 tgarip1957
-# Clean up before final commits
+# $Id: AuthoritiesMarc.pm,v 1.38 2007/03/09 14:31:47 tipaul Exp $
+# $Log: AuthoritiesMarc.pm,v $
+# Revision 1.38 2007/03/09 14:31:47 tipaul
+# rel_3_0 moved to HEAD
+#
+# Revision 1.28.2.17 2007/02/05 13:16:08 hdl
+# Removing Link from AuthoritiesMARC summary (caused a problem owed to the API differences between opac and intranet)
+# + removing $dbh in authoritysearch
+# + adding links in templates on summaries to go to full view.
+# (no more links in popup authorities. or should we add it ?)
+#
+# Revision 1.28.2.16 2007/02/02 18:07:42 hdl
+# Sorting and searching for exact term now works.
+#
+# Revision 1.28.2.15 2007/01/24 10:17:47 hdl
+# FindDuplicate Now works.
+# Be AWARE that it needs a change ccl.properties.
+#
+# Revision 1.28.2.14 2007/01/10 14:40:11 hdl
+# Adding Authorities tree.
+#
+# Revision 1.28.2.13 2007/01/09 15:18:09 hdl
+# Adding an to ccl.properties to allow ccl search for authority-numbers.
+# Fixing Some problems with the previous modification to allow pqf search to work for more than one page.
+# Using search for an= for an authority-Number.
+#
+# Revision 1.28.2.12 2007/01/09 13:51:31 hdl
+# Bug Fixing : AUTHcount_usage used *synchronous* connection where biblio used ****asynchronous**** one.
+# First try to get it work.
+#
+# Revision 1.28.2.11 2007/01/05 14:37:26 btoumi
+# bug fix : remove wrong field in sql syntaxe from auth_subfield_structure table
+#
+# Revision 1.28.2.10 2007/01/04 13:11:08 tipaul
+# commenting 2 zconn destroy
+#
+# Revision 1.28.2.9 2006/12/22 15:09:53 toins
+# removing C4::Database;
+#
+# Revision 1.28.2.8 2006/12/20 17:13:19 hdl
+# modifying use of GILS into use of @attr 1=Koha-Auth-Number
+#
+# Revision 1.28.2.7 2006/12/18 16:45:38 tipaul
+# FIXME upcased
+#
+# Revision 1.28.2.6 2006/12/07 16:45:43 toins
+# removing warn compilation. (perl -wc)
+#
+# Revision 1.28.2.5 2006/12/06 14:19:59 hdl
+# ABugFixing : Authority count Management.
+#
+# Revision 1.28.2.4 2006/11/17 13:18:58 tipaul
+# code cleaning : removing use of "bib", and replacing with "biblionumber"
+#
+# WARNING : I tried to do carefully, but there are probably some mistakes.
+# So if you encounter a problem you didn't have before, look for this change !!!
+# anyway, I urge everybody to use only "biblionumber", instead of "bib", "bi", "biblio" or anything else. will be easier to maintain !!!
+#
+# Revision 1.28.2.3 2006/11/17 11:17:30 tipaul
+# code cleaning : removing use of "bib", and replacing with "biblionumber"
+#
+# WARNING : I tried to do carefully, but there are probably some mistakes.
+# So if you encounter a problem you didn't have before, look for this change !!!
+# anyway, I urge everybody to use only "biblionumber", instead of "bib", "bi", "biblio" or anything else. will be easier to maintain !!!
+#
+# Revision 1.28.2.2 2006/10/12 22:04:47 hdl
+# Authorities working with zebra.
+# zebra Configuration files are comitted next.
+#
+# Revision 1.9.2.17.2.2 2006/07/27 16:34:56 kados
+# syncing with rel_2_2 .. .untested.
+#
+# Revision 1.9.2.17.2.1 2006/05/28 18:49:12 tgarip1957
+# This is an unusual commit. The main purpose is a working model of Zebra on a modified rel2_2.
+# Any questions regarding these commits should be asked to Joshua Ferraro unless you are Joshua whom I'll report to
#
# Revision 1.9.2.6 2005/06/07 10:02:00 tipaul
# porting dictionnary search from head to 2.2. there is now a ... facing titles, author & subject, to search in biblio & authorities existing values.
@@ -902,4 +1073,3 @@
# Revision 1.1 2004/06/07 07:35:01 tipaul
# MARC authority management package
#
-
Index: Biblio.pm
===================================================================
RCS file: /sources/koha/koha/C4/Biblio.pm,v
retrieving revision 1.187
retrieving revision 1.188
diff -u -b -r1.187 -r1.188
--- Biblio.pm 15 Nov 2006 01:36:00 -0000 1.187
+++ Biblio.pm 9 Mar 2007 14:31:47 -0000 1.188
@@ -1,5 +1,5 @@
-package C4::Biblio;
-# New XML API added by tgarip at neu.edu.tr 25/08/06
+package C4::Biblio;
+
# Copyright 2000-2002 Katipo Communications
#
# This file is part of Koha.
@@ -16,1365 +16,1021 @@
# You should have received a copy of the GNU General Public License along with
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+
use strict;
+
require Exporter;
use C4::Context;
-use XML::Simple;
-use Encode;
+use MARC::Record;
+use MARC::File::USMARC;
+use MARC::File::XML;
+use ZOOM;
+use C4::Koha;
+use C4::Date;
+use utf8;
+use C4::Log; # logaction
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 2.01;
+$VERSION = do { my @v = '$Revision: 1.188 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
- at ISA = qw(Exporter);
+ at ISA = qw( Exporter );
-# &itemcount removed, now resides in Search.pm
-#
- at EXPORT = qw(
+# EXPORTED FUNCTIONS.
-&getitemtypes
-&getkohafields
-&getshelves
-
-&NEWnewbiblio
-&NEWnewitem
-&NEWmodbiblio
-&NEWmoditem
-&NEWdelbiblio
-&NEWdelitem
-&NEWmodbiblioframework
-
-
-&MARCfind_marc_from_kohafield
-&MARCfind_frameworkcode
-&MARCfind_itemtype
-&MARCgettagslib
-&MARCitemsgettagslib
-
-&MARCfind_attr_from_kohafield
-&MARChtml2xml
-
-
-&XMLgetbiblio
-&XMLgetbibliohash
-&XMLgetitem
-&XMLgetitemhash
-&XMLgetallitems
-&XML_xml2hash
-&XML_xml2hash_onerecord
-&XML_hash2xml
-&XMLmarc2koha
-&XMLmarc2koha_onerecord
-&XML_readline
-&XML_readline_onerecord
-&XML_readline_asarray
-&XML_writeline
-&XML_writeline_id
-&XMLmoditemonefield
-&XMLkoha2marc
-&XML_separate
-&XML_record_header
-&XMLmodLCindex
-&ZEBRAdelbiblio
-&ZEBRAgetrecord
-&ZEBRAop
-&ZEBRAopserver
-&ZEBRA_readyXML
-&ZEBRA_readyXML_noheader
-&ZEBRAopcommit
-&newbiblio
-&modbiblio
-&DisplayISBN
+# to add biblios or items
+push @EXPORT, qw( &AddBiblio &AddItem );
+# to get something
+push @EXPORT, qw(
+ &GetBiblio
+ &GetBiblioData
+ &GetBiblioItemData
+ &GetBiblioItemInfosOf
+ &GetBiblioItemByBiblioNumber
+ &GetBiblioFromItemNumber
+
+ &GetItemInfosOf
+ &GetItemStatus
+ &GetItemLocation
+
+ &GetItemsInfo
+ &GetItemFromBarcode
+ &getitemsbybiblioitem
+ &get_itemnumbers_of
+ &GetAuthorisedValueDesc
+ &GetXmlBiblio
);
-#################### XML XML XML XML ###################
-### XML Read- Write functions
-sub XML_readline_onerecord{
-my ($xml,$kohafield,$recordtype,$tag,$subf)=@_;
-#$xml represents one record of MARCXML as perlhashed
-### $recordtype is needed for mapping the correct field
- ($tag,$subf)=MARCfind_marc_from_kohafield($kohafield,$recordtype) if $kohafield;
+# To modify something
+push @EXPORT, qw(
+ &ModBiblio
+ &ModItem
+ &ModBiblioframework
+);
-if ($tag){
-my $biblio=$xml->{'datafield'};
-my $controlfields=$xml->{'controlfield'};
-my $leader=$xml->{'leader'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- foreach my $subfield ( $data->{'subfield'}){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf){
- return $code->{'content'};
- }
- }
- }
- }
- }
- }else{
- if ($tag eq "000" || $tag eq "LDR"){
- return $leader->[0] if $leader->[0];
- }else{
- foreach my $control (@$controlfields){
- if ($control->{'tag'} eq $tag){
- return $control->{'content'} if $control->{'content'};
- }
- }
- }
- }##tag
-}## if tag is mapped
-return "";
-}
-sub XML_readline_asarray{
-my ($xml,$kohafield,$recordtype,$tag,$subf)=@_;
-#$xml represents one record of MARCXML as perlhashed
-## returns an array of read fields--useful for readind repeated fields
-### $recordtype is needed for mapping the correct field if supplied
-### If only $tag is give reads the whole tag
-my @value;
- ($tag,$subf)=MARCfind_marc_from_kohafield($kohafield,$recordtype) if $kohafield;
-if ($tag){
-my $biblio=$xml->{'datafield'};
-my $controlfields=$xml->{'controlfield'};
-my $leader=$xml->{'leader'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- foreach my $subfield ( $data->{'subfield'}){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf || !$subf){
- push @value, $code->{'content'};
- }
- }
- }
- }
- }
- }else{
- if ($tag eq "000" || $tag eq "LDR"){
- push @value, $leader->[0] if $leader->[0];
- }else{
- foreach my $control (@$controlfields){
- if ($control->{'tag'} eq $tag){
- push @value, $control->{'content'} if $control->{'content'};
+# To delete something
+push @EXPORT, qw(
+ &DelBiblio
+ &DelItem
+);
- }
- }
- }
- }##tag
-}## if tag is mapped
-return @value;
-}
+# Marc related functions
+push @EXPORT, qw(
+ &MARCfind_marc_from_kohafield
+ &MARCfind_frameworkcode
+ &MARCgettagslib
+ &MARCmoditemonefield
+ &MARCaddbiblio
+ &MARCadditem
+ &MARCmodbiblio
+ &MARCmoditem
+ &MARCkoha2marcBiblio
+ &MARCmarc2koha
+ &MARCkoha2marcItem
+ &MARChtml2marc
+ &MARChtml2xml
+ &MARCgetitem
+ &MARCaddword
+ &MARCdelword
+ &MARCdelsubfield
+ &GetMarcNotes
+ &GetMarcSubjects
+ &GetMarcBiblio
+ &GetMarcAuthors
+ &GetMarcSeries
+ &Koha2Marc
+);
-sub XML_readline{
-my ($xml,$kohafield,$recordtype,$tag,$subf)=@_;
-#$xml represents one record node hashed of holdings or a complete xml koharecord
-### $recordtype is needed for reading the child records( like holdings records) .Otherwise main record is assumed ( like biblio)
-## holding records are parsed and sent here one by one
-# If kohafieldname given find tag
+# Others functions
+push @EXPORT, qw(
+ &PrepareItemrecordDisplay
+ &zebraop
+ &char_decode
+ &itemcalculator
+ &calculatelc
+);
-($tag,$subf)=MARCfind_marc_from_kohafield($kohafield,$recordtype) if $kohafield;
-my @itemresults;
-if ($tag){
-if ($recordtype eq "holdings"){
- my $item=$xml->{'datafield'};
- my $hcontrolfield=$xml->{'controlfield'};
- if ($tag>9){
- foreach my $data (@$item){
- if ($data->{'tag'} eq $tag){
- foreach my $subfield ( $data->{'subfield'}){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf){
- return $code->{content};
- }
- }
- }
- }
- }
- }else{
- foreach my $control (@$hcontrolfield){
- if ($control->{'tag'} eq $tag){
- return $control->{'content'};
- }
- }
- }##tag
+# OLD functions,
+push @EXPORT, qw(
+ &newitems
+ &modbiblio
+ &modbibitem
+ &moditem
+ &checkitems
+);
-}else{ ##Not a holding read biblio
-my $biblio=$xml->{'record'}->[0]->{'datafield'};
-my $controlfields=$xml->{'record'}->[0]->{'controlfield'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- foreach my $subfield ( $data->{'subfield'}){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf){
- return $code->{'content'};
- }
- }
- }
- }
- }
- }else{
+=head1 NAME
- foreach my $control (@$controlfields){
- if ($control->{'tag'} eq $tag){
- return $control->{'content'}if $control->{'content'};
- }
- }
- }##tag
-}## Holding or not
-}## if tag is mapped
-return "";
-}
+C4::Biblio - acquisitions and cataloging management functions
-sub XML_writeline{
-## This routine modifies one line of marcxml record hash
-my ($xml,$kohafield,$newvalue,$recordtype,$tag,$subf)=@_;
-$newvalue= Encode::decode('utf8',$newvalue) if $newvalue;
-my $biblio=$xml->{'datafield'};
-my $controlfield=$xml->{'controlfield'};
- ($tag,$subf)=MARCfind_marc_from_kohafield($kohafield,$recordtype) if $kohafield;
-my $updated;
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- my @subfields=$data->{'subfield'};
- my @newsubs;
- foreach my $subfield ( @subfields){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf){
- $code->{'content'}=$newvalue;
- $updated=1;
- }
- push @newsubs,$code;
- }
- }
- if (!$updated){
- push @newsubs,{code=>$subf,content=>$newvalue};
- $data->{subfield}= \@newsubs;
- $updated=1;
- }
- }
- }
- ## Tag did not exist
- if (!$updated){
- if ($subf){
- push @$biblio,
- {
- 'ind1' => ' ',
- 'ind2' => ' ',
- 'subfield' => [
- {
- 'content' =>$newvalue,
- 'code' => $subf
- }
- ],
- 'tag' =>$tag
- } ;
- }else{
- push @$biblio,
- {
- 'ind1' => ' ',
- 'ind2' => ' ',
- 'tag' =>$tag
- } ;
- }
- }## created now
- }elsif ($tag>0){
- foreach my $control (@$controlfield){
- if ($control->{'tag'} eq $tag){
- $control->{'content'}=$newvalue;
- $updated=1;
- }
- }
- if (!$updated){
- push @$controlfield,{tag=>$tag,content=>$newvalue};
- }
- }
-return $xml;
-}
+=head1 DESCRIPTION
-sub XML_writeline_id {
-### This routine is similar to XML_writeline but replaces a given value and do not create a new field
-## Useful for repeating fields
-## Currently usedin authorities
-my ($xml,$oldvalue,$newvalue,$tag,$subf)=@_;
-$newvalue= Encode::decode('utf8',$newvalue) if $newvalue;
-my $biblio=$xml->{'datafield'};
-my $controlfield=$xml->{'controlfield'};
- if ($tag>9){
- foreach my $data (@$biblio){
- if ($data->{'tag'} eq $tag){
- my @subfields=$data->{'subfield'};
- foreach my $subfield ( @subfields){
- foreach my $code ( @$subfield){
- if ($code->{'code'} eq $subf && $code->{'content'} eq $oldvalue){
- $code->{'content'}=$newvalue;
- }
- }
- }
- }
- }
- }else{
- foreach my $control(@$controlfield){
- if ($control->{'tag'} eq $tag && $control->{'content'} eq $oldvalue ){
- $control->{'content'}=$newvalue;
- }
- }
- }
-return $xml;
-}
+Biblio.pm contains functions for managing storage and editing of bibliographic data within Koha. Most of the functions in this module are used for cataloging records: adding, editing, or removing biblios, biblioitems, or items. Koha's stores bibliographic information in three places:
-sub XML_xml2hash{
-##make a perl hash from xml file
-my ($xml)=@_;
- my $hashed = XMLin( $xml ,KeyAttr =>['leader','controlfield','datafield'],ForceArray => ['leader','controlfield','datafield','subfield','holdings','record'],KeepRoot=>0);
-return $hashed;
-}
+=over 4
-sub XML_separate{
-##Separates items from biblio
-my $hashed=shift;
-my $biblio=$hashed->{record}->[0];
-my @items;
-my $items=$hashed->{holdings}->[0]->{record};
-foreach my $item (@$items){
- push @items,$item;
-}
-return ($biblio, at items);
-}
+=item 1. in the biblio,biblioitems,items, etc tables, which are limited to a one-to-one mapping to underlying MARC data
-sub XML_xml2hash_onerecord{
-##make a perl hash from xml file
-my ($xml)=@_;
-return undef unless $xml;
- my $hashed = XMLin( $xml ,KeyAttr =>['leader','controlfield','datafield'],ForceArray => ['leader','controlfield','datafield','subfield'],KeepRoot=>0);
-return $hashed;
-}
-sub XML_hash2xml{
-## turn a hash back to xml
-my ($hashed,$root)=@_;
-$root="record" unless $root;
-my $xml= XMLout($hashed,KeyAttr=>['leader','controlfıeld','datafield'],NoSort => 1,AttrIndent => 0,KeepRoot=>0,SuppressEmpty => 1,RootName=>$root );
-return $xml;
-}
+=item 2. as raw MARC in the Zebra index and storage engine
+=item 3. as raw MARC the biblioitems.marc
+=back
-sub XMLgetbiblio {
- # Returns MARC::XML of the biblionumber passed in parameter.
- my ( $dbh, $biblionumber ) = @_;
- my $sth = $dbh->prepare("select marcxml from biblio where biblionumber=? " );
- $sth->execute( $biblionumber);
- my ($marcxml)=$sth->fetchrow;
- $marcxml=Encode::decode('utf8',$marcxml);
- return ($marcxml);
-}
-
-sub XMLgetbibliohash{
-## Utility to return s hashed MARCXML
-my ($dbh,$biblionumber)=@_;
-my $xml=XMLgetbiblio($dbh,$biblionumber);
-my $xmlhash=XML_xml2hash_onerecord($xml);
-return $xmlhash;
-}
-
-sub XMLgetitem {
- # Returns MARC::XML of the item passed in parameter uses either itemnumber or barcode
- my ( $dbh, $itemnumber,$barcode ) = @_;
-my $sth;
-if ($itemnumber){
- $sth = $dbh->prepare("select marcxml from items where itemnumber=?" );
- $sth->execute($itemnumber);
-}else{
- $sth = $dbh->prepare("select marcxml from items where barcode=?" );
- $sth->execute($barcode);
-}
- my ($marcxml)=$sth->fetchrow;
-$marcxml=Encode::decode('utf8',$marcxml);
- return ($marcxml);
-}
-sub XMLgetitemhash{
-## Utility to return s hashed MARCXML
- my ( $dbh, $itemnumber,$barcode ) = @_;
-my $xml=XMLgetitem( $dbh, $itemnumber,$barcode);
-my $xmlhash=XML_xml2hash_onerecord($xml);
-return $xmlhash;
-}
+In the 2.4 version of Koha, the authoritative record-level information is in biblioitems.marc and the authoritative items information is in the items table.
+Because the data isn't completely normalized there's a chance for information to get out of sync. The design choice to go with a un-normalized schema was driven by performance and stability concerns:
-sub XMLgetallitems {
-# warn "XMLgetallitems";
- # Returns an array of MARC:XML of the items passed in parameter as biblionumber
- my ( $dbh, $biblionumber ) = @_;
-my @results;
-my $sth = $dbh->prepare("select marcxml from items where biblionumber =?" );
- $sth->execute($biblionumber);
+=over 4
- while(my ($marcxml)=$sth->fetchrow_array){
-$marcxml=Encode::decode('utf8',$marcxml);
- push @results,$marcxml;
-}
-return @results;
-}
+=item 1. Compared with MySQL, Zebra is slow to update an index for small data changes -- especially for proc-intensive operations like circulation
-sub XMLmarc2koha {
-# warn "XMLmarc2koha";
-##Returns two hashes from KOHA_XML record hashed
-## A biblio hash and and array of item hashes
- my ($dbh,$xml,$related_record, at fields) = @_;
- my ($result, at items);
+=item 2. Zebra's index has been known to crash and a backup of the data is necessary to rebuild it in such cases
-## if @fields is given do not bother about the rest of fields just parse those
+=back
-if ($related_record eq "biblios" || $related_record eq "" || !$related_record){
- if (@fields){
- foreach my $field(@fields){
- my $val=&XML_readline($xml,$field,'biblios');
- $result->{$field}=$val if $val;
+Because of this design choice, the process of managing storage and editing is a bit convoluted. Historically, Biblio.pm's grown to an unmanagable size and as a result we have several types of functions currently:
- }
- }else{
- 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) {
- $result->{$field}=&XML_readline($xml,$field,'biblios');
- }
- }
+=over 4
-## we only need the following for biblio data
+=item 1. Add*/Mod*/Del*/ - high-level external functions suitable for being called from external scripts to manage the collection
-# modify copyrightdate to keep only the 1st year found
- my $temp = $result->{'copyrightdate'};
- $temp =~ m/c(\d\d\d\d)/; # search cYYYY first
- if ($1>0) {
- $result->{'copyrightdate'} = $1;
- } else { # if no cYYYY, get the 1st date.
- $temp =~ m/(\d\d\d\d)/;
- $result->{'copyrightdate'} = $1;
- }
-# modify publicationyear to keep only the 1st year found
- $temp = $result->{'publicationyear'};
- $temp =~ m/c(\d\d\d\d)/; # search cYYYY first
- if ($1>0) {
- $result->{'publicationyear'} = $1;
- } else { # if no cYYYY, get the 1st date.
- $temp =~ m/(\d\d\d\d)/;
- $result->{'publicationyear'} = $1;
- }
-}
-if ($related_record eq "holdings" || $related_record eq "" || !$related_record){
-my $holdings=$xml->{holdings}->[0]->{record};
+=item 2. _koha_* - low-level internal functions for managing the koha tables
+=item 3. MARC* functions for interacting with the MARC data in both biblioitems.marc Zebra (biblioitems.marc is authoritative)
- if (@fields){
- foreach my $holding (@$holdings){
-my $itemresult;
- foreach my $field(@fields){
- my $val=&XML_readline($holding,$field,'holdings');
- $itemresult->{$field}=$val if $val;
- }
- push @items, $itemresult;
- }
- }else{
- 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;
-my $itemresult;
- while ($field=$sth2->fetchrow) {
- $itemresult->{$field}=&XML_readline($xml,$field,'holdings');
- }
- push @items, $itemresult;
- }
- }
+=item 4. Zebra functions used to update the Zebra index
-}
+=item 5. internal helper functions such as char_decode, checkitems, etc. Some of these probably belong in Koha.pm
- return ($result, at items);
-}
-sub XMLmarc2koha_onerecord {
-# warn "XMLmarc2koha_onerecord";
-##Returns a koha hash from MARCXML hash
+=item 6. other functions that don't belong in Biblio.pm that will be cleaned out in time. (like MARCfind_marc_from_kohafield which belongs in Search.pm)
- my ($dbh,$xml,$related_record, at fields) = @_;
- my ($result);
+In time, as we solidify the new API these older functions will be weeded out.
-## if @fields is given do not bother about the rest of fields just parse those
+=back
- if (@fields){
- foreach my $field(@fields){
- my $val=&XML_readline_onerecord($xml,$field,$related_record);
- $result->{$field}=$val if $val;
- }
- }else{
- 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) {
- $result->{$field}=&XML_readline_onerecord($xml,$field,$related_record);
- }
+=head1 EXPORTED FUNCTIONS
+
+=head2 AddBiblio
+
+($biblionumber,$biblioitemnumber) = AddBiblio($record,$frameworkcode);
+
+Exported function (core API) for adding a new biblio to koha.
+
+=cut
+
+sub AddBiblio {
+ my ( $record, $frameworkcode ) = @_;
+ my $oldbibnum;
+ my $oldbibitemnum;
+ my $dbh = C4::Context->dbh;
+ # transform the data into koha-table style data
+ my $olddata = MARCmarc2koha( $dbh, $record, $frameworkcode );
+ $oldbibnum = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
+ $olddata->{'biblionumber'} = $oldbibnum;
+ $oldbibitemnum = _koha_add_biblioitem( $dbh, $olddata );
+
+ # we must add bibnum and bibitemnum in MARC::Record...
+ # we build the new field with biblionumber and biblioitemnumber
+ # we drop the original field
+ # we add the new builded field.
+ # NOTE : Works only if the field is ONLY for biblionumber and biblioitemnumber
+ # (steve and paul : thinks 090 is a good choice)
+ my $sth =
+ $dbh->prepare(
+ "SELECT tagfield,tagsubfield
+ FROM marc_subfield_structure
+ WHERE kohafield=?"
+ );
+ $sth->execute("biblio.biblionumber");
+ ( my $tagfield1, my $tagsubfield1 ) = $sth->fetchrow;
+ $sth->execute("biblioitems.biblioitemnumber");
+ ( my $tagfield2, my $tagsubfield2 ) = $sth->fetchrow;
+
+ my $newfield;
+
+ # biblionumber & biblioitemnumber are in different fields
+ if ( $tagfield1 != $tagfield2 ) {
+
+ # deal with biblionumber
+ if ( $tagfield1 < 10 ) {
+ $newfield = MARC::Field->new( $tagfield1, $oldbibnum, );
+ }
+ else {
+ $newfield =
+ MARC::Field->new( $tagfield1, '', '',
+ "$tagsubfield1" => $oldbibnum, );
+ }
+
+ # drop old field and create new one...
+ my $old_field = $record->field($tagfield1);
+ $record->delete_field($old_field);
+ $record->append_fields($newfield);
+
+ # deal with biblioitemnumber
+ if ( $tagfield2 < 10 ) {
+ $newfield = MARC::Field->new( $tagfield2, $oldbibitemnum, );
+ }
+ else {
+ $newfield =
+ MARC::Field->new( $tagfield2, '', '',
+ "$tagsubfield2" => $oldbibitemnum, );
+ }
+ # drop old field and create new one...
+ $old_field = $record->field($tagfield2);
+ $record->delete_field($old_field);
+ $record->insert_fields_ordered($newfield);
+
+# biblionumber & biblioitemnumber are in the same field (can't be <10 as fields <10 have only 1 value)
+ }
+ else {
+ my $newfield = MARC::Field->new(
+ $tagfield1, '', '',
+ "$tagsubfield1" => $oldbibnum,
+ "$tagsubfield2" => $oldbibitemnum
+ );
+
+ # drop old field and create new one...
+ my $old_field = $record->field($tagfield1);
+ $record->delete_field($old_field);
+ $record->insert_fields_ordered($newfield);
}
- return ($result);
-}
-sub XMLmodLCindex{
-# warn "XMLmodLCindex";
-my ($dbh,$xmlhash)=@_;
-my ($lc)=XML_readline_onerecord($xmlhash,"classification","biblios");
-my ($cutter)=XML_readline_onerecord($xmlhash,"subclass","biblios");
-
- if ($lc){
- $lc.=$cutter;
- my ($lcsort)=calculatelc($lc);
- $xmlhash=XML_writeline($xmlhash,"lcsort",$lcsort,"biblios");
- }
-return $xmlhash;
-}
-
-sub XMLmoditemonefield{
-# This routine takes itemnumber and biblionumber and updates XMLmarc;
-### the ZEBR DB update can wait depending on $donotupdate flag
-my ($dbh,$biblionumber,$itemnumber,$itemfield,$newvalue,$donotupdate)=@_;
-my ($record) = XMLgetitem($dbh,$itemnumber);
- my $recordhash=XML_xml2hash_onerecord($record);
- XML_writeline( $recordhash, $itemfield, $newvalue,"holdings" );
- if($donotupdate){
- ## Prevent various update calls to zebra wait until all changes finish
- $record=XML_hash2xml($recordhash);
- my $sth=$dbh->prepare("update items set marcxml=? where itemnumber=?");
- $sth->execute($record,$itemnumber);
- $sth->finish;
- }else{
- NEWmoditem($dbh,$recordhash,$biblionumber,$itemnumber);
+ ###NEU specific add cataloguers cardnumber as well
+ my $cardtag = C4::Context->preference('cataloguersfield');
+ if ($cardtag) {
+ my $tag = substr( $cardtag, 0, 3 );
+ my $subf = substr( $cardtag, 3, 1 );
+ my $me = C4::Context->userenv;
+ my $cataloger = $me->{'cardnumber'} if ($me);
+ my $newtag = MARC::Field->new( $tag, '', '', $subf => $cataloger )
+ if ($me);
+ $record->delete_field($newtag);
+ $record->insert_fields_ordered($newtag);
}
-}
+ # now add the record
+ my $biblionumber =
+ MARCaddbiblio( $record, $oldbibnum, $frameworkcode );
-sub XMLkoha2marc {
-# warn "MARCkoha2marc";
-## This routine is still used for acqui management
-##Returns a XML recordhash from a kohahash
- my ($dbh,$result,$recordtype) = @_;
-###create a basic MARCXML
-# find today's date
-my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
- $year += 1900;
- $mon += 1;
- my $timestamp = sprintf("%4d%02d%02d%02d%02d%02d.0",
- $year,$mon,$mday,$hour,$min,$sec);
-$year=substr($year,2,2);
- my $accdate=sprintf("%2d%02d%02d",$year,$mon,$mday);
-my ($titletag,$titlesubf)=MARCfind_marc_from_kohafield("title","biblios");
-##create a dummy record
-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 kohafield from koha_attr where tagfield is not null and recordtype=?");
- $sth2->execute($recordtype);
- my $field;
- while (($field)=$sth2->fetchrow) {
- $record=XML_writeline($record,$field,$result->{$field},$recordtype) if $result->{$field};
- }
-return $record;
-}
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","ADD",$biblionumber,"biblio")
+ if C4::Context->preference("CataloguingLog");
-#
-#
-# MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC MARC
-#
-## Script to deal with MARCXML related tables
+ return ( $biblionumber, $oldbibitemnum );
+}
+=head2 AddItem
-##Sub to match kohafield to Z3950 -attributes
+$biblionumber = AddItem( $record, $biblionumber)
-sub MARCfind_attr_from_kohafield {
-# warn "MARCfind_attr_from_kohafield";
-## returns attribute
- my ( $kohafield ) = @_;
- return 0, 0 unless $kohafield;
+Exported function (core API) for adding a new item to Koha
- my $relations = C4::Context->attrfromkohafield;
- return ($relations->{$kohafield});
-}
+=cut
+sub AddItem {
+ my ( $record, $biblionumber ) = @_;
+ my $dbh = C4::Context->dbh;
-sub MARCgettagslib {
-# warn "MARCgettagslib";
- my ( $dbh, $forlibrarian, $frameworkcode ) = @_;
- $frameworkcode = "" unless $frameworkcode;
- my $sth;
- my $libfield = ( $forlibrarian eq 1 ) ? 'liblibrarian' : 'libopac';
+ # add item in old-DB
+ my $frameworkcode = MARCfind_frameworkcode( $biblionumber );
+ my $item = &MARCmarc2koha( $dbh, $record, $frameworkcode );
- # check that framework exists
- $sth =
+ # needs old biblionumber and biblioitemnumber
+ $item->{'biblionumber'} = $biblionumber;
+ my $sth =
$dbh->prepare(
- "select count(*) from biblios_tag_structure where frameworkcode=?");
- $sth->execute($frameworkcode);
- my ($total) = $sth->fetchrow;
- $frameworkcode = "" unless ( $total > 0 );
+ "select biblioitemnumber,itemtype from biblioitems where biblionumber=?"
+ );
+ $sth->execute( $item->{'biblionumber'} );
+ my $itemtype;
+ ( $item->{'biblioitemnumber'}, $itemtype ) = $sth->fetchrow;
$sth =
$dbh->prepare(
-"select tagfield,liblibrarian,libopac,mandatory,repeatable from biblios_tag_structure where frameworkcode=? order by tagfield"
- );
- $sth->execute($frameworkcode);
- my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable );
-
- while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) = $sth->fetchrow ) {
- $res->{$tag}->{lib} = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
- $res->{$tab}->{tab} = ""; # XXX
- $res->{$tag}->{mandatory} = $mandatory;
- $res->{$tag}->{repeatable} = $repeatable;
+ "select notforloan from itemtypes where itemtype='$itemtype'");
+ $sth->execute();
+ my $notforloan = $sth->fetchrow;
+ ##Change the notforloan field if $notforloan found
+ if ( $notforloan > 0 ) {
+ $item->{'notforloan'} = $notforloan;
+ &MARCitemchange( $record, "items.notforloan", $notforloan );
+ }
+ if ( !$item->{'dateaccessioned'} || $item->{'dateaccessioned'} eq '' ) {
+
+ # find today's date
+ my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
+ localtime(time);
+ $year += 1900;
+ $mon += 1;
+ my $date =
+ "$year-" . sprintf( "%0.2d", $mon ) . "-" . sprintf( "%0.2d", $mday );
+ $item->{'dateaccessioned'} = $date;
+ &MARCitemchange( $record, "items.dateaccessioned", $date );
}
+ my ( $itemnumber, $error ) =
+ &_koha_new_items( $dbh, $item, $item->{barcode} );
+ # add itemnumber to MARC::Record before adding the item.
$sth =
$dbh->prepare(
-"select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,seealso,hidden,isurl,link from biblios_subfield_structure where frameworkcode=? order by tagfield,tagsubfield"
+"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
);
- $sth->execute($frameworkcode);
+ &MARCkoha2marcOnefield( $sth, $record, "items.itemnumber", $itemnumber,
+ $frameworkcode );
- my $subfield;
- my $authorised_value;
- my $authtypecode;
- my $value_builder;
+ ##NEU specific add cataloguers cardnumber as well
+ my $cardtag = C4::Context->preference('itemcataloguersubfield');
+ if ($cardtag) {
+ $sth->execute( $frameworkcode, "items.itemnumber" );
+ my ( $itemtag, $subtag ) = $sth->fetchrow;
+ my $me = C4::Context->userenv;
+ my $cataloguer = $me->{'cardnumber'} if ($me);
+ my $newtag = $record->field($itemtag);
+ $newtag->update( $cardtag => $cataloguer ) if ($me);
+ $record->delete_field($newtag);
+ $record->append_fields($newtag);
+ }
- my $seealso;
- my $hidden;
- my $isurl;
- my $link;
+ # add the item
+ &MARCadditem( $record, $item->{'biblionumber'},$frameworkcode );
- while (
- ( $tag, $subfield, $liblibrarian, , $libopac, $tab,
- $mandatory, $repeatable, $authorised_value, $authtypecode,
- $value_builder, $seealso, $hidden,
- $isurl, $link )
- = $sth->fetchrow
- )
- {
- $res->{$tag}->{$subfield}->{lib} = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
- $res->{$tag}->{$subfield}->{tab} = $tab;
- $res->{$tag}->{$subfield}->{mandatory} = $mandatory;
- $res->{$tag}->{$subfield}->{repeatable} = $repeatable;
- $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
- $res->{$tag}->{$subfield}->{authtypecode} = $authtypecode;
- $res->{$tag}->{$subfield}->{value_builder} = $value_builder;
- $res->{$tag}->{$subfield}->{seealso} = $seealso;
- $res->{$tag}->{$subfield}->{hidden} = $hidden;
- $res->{$tag}->{$subfield}->{isurl} = $isurl;
- $res->{$tag}->{$subfield}->{link} = $link;
- }
- return $res;
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","ADD",$itemnumber,"item")
+ if C4::Context->preference("CataloguingLog");
+
+ return ($item->{biblionumber}, $item->{biblioitemnumber},$itemnumber);
}
-sub MARCitemsgettagslib {
-# warn "MARCitemsgettagslib";
- my ( $dbh, $forlibrarian, $frameworkcode ) = @_;
- $frameworkcode = "" unless $frameworkcode;
- my $sth;
- my $libfield = ( $forlibrarian eq 1 ) ? 'liblibrarian' : 'libopac';
- # check that framework exists
- $sth =
- $dbh->prepare(
- "select count(*) from holdings_tag_structure where frameworkcode=?");
- $sth->execute($frameworkcode);
- my ($total) = $sth->fetchrow;
- $frameworkcode = "" unless ( $total > 0 );
- $sth =
- $dbh->prepare(
-"select tagfield,liblibrarian,libopac,mandatory,repeatable from holdings_tag_structure where frameworkcode=? order by tagfield"
- );
- $sth->execute($frameworkcode);
- my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable );
+=head2 ModBiblio
- while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) = $sth->fetchrow ) {
- $res->{$tag}->{lib} = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
- $res->{$tab}->{tab} = ""; # XXX
- $res->{$tag}->{mandatory} = $mandatory;
- $res->{$tag}->{repeatable} = $repeatable;
- }
+ModBiblio( $record,$biblionumber,$frameworkcode);
- $sth =
- $dbh->prepare(
-"select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,seealso,hidden,isurl,link from holdings_subfield_structure where frameworkcode=? order by tagfield,tagsubfield"
- );
- $sth->execute($frameworkcode);
+Exported function (core API) to modify a biblio
- my $subfield;
- my $authorised_value;
- my $authtypecode;
- my $value_builder;
+=cut
- my $seealso;
- my $hidden;
- my $isurl;
- my $link;
+sub ModBiblio {
+ my ( $record, $biblionumber, $frameworkcode ) = @_;
- while (
- ( $tag, $subfield, $liblibrarian, , $libopac, $tab,
- $mandatory, $repeatable, $authorised_value, $authtypecode,
- $value_builder, $seealso, $hidden,
- $isurl, $link )
- = $sth->fetchrow
- )
- {
- $res->{$tag}->{$subfield}->{lib} = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
- $res->{$tag}->{$subfield}->{tab} = $tab;
- $res->{$tag}->{$subfield}->{mandatory} = $mandatory;
- $res->{$tag}->{$subfield}->{repeatable} = $repeatable;
- $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
- $res->{$tag}->{$subfield}->{authtypecode} = $authtypecode;
- $res->{$tag}->{$subfield}->{value_builder} = $value_builder;
- $res->{$tag}->{$subfield}->{seealso} = $seealso;
- $res->{$tag}->{$subfield}->{hidden} = $hidden;
- $res->{$tag}->{$subfield}->{isurl} = $isurl;
- $res->{$tag}->{$subfield}->{link} = $link;
+ if (C4::Context->preference("CataloguingLog")) {
+ my $newrecord = GetMarcBiblio($biblionumber);
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","MODIFY",$biblionumber,$newrecord->as_formatted)
}
- return $res;
-}
-sub MARCfind_marc_from_kohafield {
-# warn "MARCfind_marc_from_kohafield";
- my ( $kohafield,$recordtype) = @_;
- return 0, 0 unless $kohafield;
-$recordtype="biblios" unless $recordtype;
- my $relations = C4::Context->marcfromkohafield;
- return ($relations->{$recordtype}->{$kohafield}->[0],$relations->{$recordtype}->{$kohafield}->[1]);
-}
+ my $dbh = C4::Context->dbh;
+ $frameworkcode = "" unless $frameworkcode;
+ # update the MARC record with the new record data
+ &MARCmodbiblio( $dbh, $biblionumber, $record, $frameworkcode, 1 );
-sub MARCfind_frameworkcode {
-# warn "MARCfind_frameworkcode";
- my ( $dbh, $biblionumber ) = @_;
- my $sth =
- $dbh->prepare("select frameworkcode from biblio where biblionumber=?");
- $sth->execute($biblionumber);
- my ($frameworkcode) = $sth->fetchrow;
- return $frameworkcode;
-}
-sub MARCfind_itemtype {
-# warn "MARCfind_itemtype";
- my ( $dbh, $biblionumber ) = @_;
- my $sth =
- $dbh->prepare("select itemtype from biblio where biblionumber=?");
- $sth->execute($biblionumber);
- my ($itemtype) = $sth->fetchrow;
- return $itemtype;
+ # load the koha-table data object
+ my $oldbiblio = MARCmarc2koha( $dbh, $record, $frameworkcode );
+
+ # modify the other koha tables
+ my $oldbiblionumber = _koha_modify_biblio( $dbh, $oldbiblio );
+ _koha_modify_biblioitem( $dbh, $oldbiblio );
+
+ return 1;
}
+=head2 ModItem
+Exported function (core API) for modifying an item in Koha.
-sub MARChtml2xml {
-# warn "MARChtml2xml ";
- my ($tags,$subfields,$values,$indicator,$ind_tag,$tagindex) = @_;
- my $xml= "<record>";
+=cut
- my $prevvalue;
- my $prevtag=-1;
- my $first=1;
- my $j = -1;
- for (my $i=0;$i<=@$tags;$i++){
- @$values[$i] =~ s/&/&/g;
- @$values[$i] =~ s/</</g;
- @$values[$i] =~ s/>/>/g;
- @$values[$i] =~ s/"/"/g;
- @$values[$i] =~ s/'/'/g;
+sub ModItem {
+ my ( $record, $biblionumber, $itemnumber, $delete, $new_item_hashref )
+ = @_;
- if ((@$tags[$i].@$tagindex[$i] ne $prevtag)){
- my $tag=@$tags[$i];
- $j++ unless ($tag eq "");
- ## warn "IND:".substr(@$indicator[$j],0,1).substr(@$indicator[$j],1,1)." ".@$tags[$i];
- if (!$first){
- $xml.="</datafield>\n";
- if (($tag> 10) && (@$values[$i] ne "")){
- my $ind1 = substr(@$indicator[$j],0,1);
- my $ind2 = substr(@$indicator[$j],1,1);
- $xml.="<datafield tag=\"$tag\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
- $xml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
- $first=0;
- } else {
- $first=1;
- }
- } else {
- if (@$values[$i] ne "") {
- # leader
- if ($tag eq "000") {
- ##Force the leader to UTF8
- substr(@$values[$i],9,1)="a";
- $xml.="<leader>@$values[$i]</leader>\n";
- $first=1;
- # rest of the fixed fields
- } elsif ($tag < 10) {
- $xml.="<controlfield tag=\"$tag\">@$values[$i]</controlfield>\n";
- $first=1;
- } else {
- my $ind1 = substr(@$indicator[$j],0,1);
- my $ind2 = substr(@$indicator[$j],1,1);
- $xml.="<datafield tag=\"$tag\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
- $xml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
- $first=0;
- }
+ #logging
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","MODIFY",$itemnumber,$record->as_formatted)
+ if C4::Context->preference("CataloguingLog");
+
+ my $dbh = C4::Context->dbh;
+
+ # if we have a MARC record, we're coming from cataloging and so
+ # we do the whole routine: update the MARC and zebra, then update the koha
+ # tables
+ if ($record) {
+ my $frameworkcode = MARCfind_frameworkcode( $biblionumber );
+ MARCmoditem( $record, $biblionumber, $itemnumber, $frameworkcode, $delete );
+ my $olditem = MARCmarc2koha( $dbh, $record, $frameworkcode );
+ _koha_modify_item( $dbh, $olditem );
+ return $biblionumber;
}
+
+ # otherwise, we're just looking to modify something quickly
+ # (like a status) so we just update the koha tables
+ elsif ($new_item_hashref) {
+ _koha_modify_item( $dbh, $new_item_hashref );
}
- } else { # @$tags[$i] eq $prevtag
- unless (@$values[$i] eq "") {
- my $tag=@$tags[$i];
- if ($first){
- my $ind1 = substr(@$indicator[$j],0,1);
- my $ind2 = substr(@$indicator[$j],1,1);
- $xml.="<datafield tag=\"$tag\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
- $first=0;
- }
- $xml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
- }
- }
- $prevtag = @$tags[$i].@$tagindex[$i];
- }
- $xml.="</record>";
- # warn $xml;
- $xml=Encode::decode('utf8',$xml);
- return $xml;
-}
-sub XML_record_header {
-#### this one is for <record>
- my $format = shift;
- my $enc = shift || 'UTF-8';
-##
- return( <<MARC_XML_HEADER );
-<?xml version="1.0" encoding="$enc"?>
-<record xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
- xmlns="http://www.loc.gov/MARC21/slim">
-MARC_XML_HEADER
}
+=head2 ModBiblioframework
+
+ModBiblioframework($biblionumber,$frameworkcode);
+
+Exported function to modify a biblio framework
+
+=cut
+
+sub ModBiblioframework {
+ my ( $biblionumber, $frameworkcode ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "UPDATE biblio SET frameworkcode=? WHERE biblionumber=$biblionumber");
-sub collection_header {
-#### this one is for koha collection
- my $format = shift;
- my $enc = shift || 'UTF-8';
- return( <<KOHA_XML_HEADER );
-<?xml version="1.0" encoding="$enc"?>
-<kohacollection xmlns:marc="http://loc.gov/MARC21/slim" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="http://library.neu.edu.tr/kohanamespace/koharecord.xsd">
-KOHA_XML_HEADER
+ warn "IN ModBiblioframework";
+ $sth->execute($frameworkcode);
+ return 1;
}
+=head2 DelBiblio
+my $error = &DelBiblio($dbh,$biblionumber);
+Exported function (core API) for deleting a biblio in koha.
+Deletes biblio record from Zebra and Koha tables (biblio,biblioitems,items)
+Also backs it up to deleted* tables
+Checks to make sure there are not issues on any of the items
+return:
+C<$error> : undef unless an error occurs
-##########################NEW NEW NEW#############################
-sub NEWnewbiblio {
- my ( $dbh, $xml, $frameworkcode) = @_;
-$frameworkcode="" unless $frameworkcode;
-my $biblionumber=XML_readline_onerecord($xml,"biblionumber","biblios");
-## In case reimporting records with biblionumbers keep them
-if ($biblionumber){
-$biblionumber=NEWmodbiblio( $dbh, $biblionumber,$xml,$frameworkcode );
-}else{
- $biblionumber = NEWaddbiblio( $dbh, $xml,$frameworkcode );
-}
+=cut
- return ( $biblionumber );
-}
+sub DelBiblio {
+ my ( $biblionumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $error; # for error handling
+ # First make sure there are no items with issues are still attached
+ my $sth =
+ $dbh->prepare(
+ "SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=?");
+ $sth->execute($biblionumber);
+ while ( my $biblioitemnumber = $sth->fetchrow ) {
+ my @issues = C4::Circulation::Circ2::itemissues($biblioitemnumber);
+ foreach my $issue (@issues) {
+ if ( ( $issue->{date_due} )
+ && ( $issue->{date_due} ne "Available" ) )
+ {
+#FIXME: we need a status system in Biblio like in Circ to return standard codes and messages
+# instead of hard-coded strings
+ $error .=
+"Item is checked out to a patron -- you must return it before deleting the Biblio";
+ }
+ }
+ }
+ return $error if $error;
+ # Delete in Zebra
+ zebraop($dbh,$biblionumber,"delete_record","biblioserver");
+ # delete biblio from Koha tables and save in deletedbiblio
+ $error = &_koha_delete_biblio( $dbh, $biblionumber );
-sub NEWmodbiblioframework {
- my ($dbh,$biblionumber,$frameworkcode) =@_;
- my $sth = $dbh->prepare("Update biblio SET frameworkcode=? WHERE biblionumber=$biblionumber");
- $sth->execute($frameworkcode);
- return 1;
-}
+ # delete biblioitems and items from Koha tables and save in deletedbiblioitems,deleteditems
+ $sth =
+ $dbh->prepare(
+ "SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=?");
+ $sth->execute($biblionumber);
+ while ( my $biblioitemnumber = $sth->fetchrow ) {
+ # delete this biblioitem
+ $error = &_koha_delete_biblioitems( $dbh, $biblioitemnumber );
+ return $error if $error;
-sub NEWdelbiblio {
- my ( $dbh, $biblionumber ) = @_;
-ZEBRAop($dbh,$biblionumber,"recordDelete","biblioserver");
+ # delete items
+ my $items_sth =
+ $dbh->prepare(
+ "SELECT itemnumber FROM items WHERE biblioitemnumber=?");
+ $items_sth->execute($biblioitemnumber);
+ while ( my $itemnumber = $items_sth->fetchrow ) {
+ $error = &_koha_delete_items( $dbh, $itemnumber );
+ return $error if $error;
+ }
+ }
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","DELETE",$biblionumber,"")
+ if C4::Context->preference("CataloguingLog");
+ return;
}
+=head2 DelItem
-sub NEWnewitem {
- my ( $dbh, $xmlhash, $biblionumber ) = @_;
- my $itemtype= MARCfind_itemtype($dbh,$biblionumber);
+DelItem( $biblionumber, $itemnumber );
-## In case we are re-importing marc records from bulk import do not change itemnumbers
-my $itemnumber=XML_readline_onerecord($xmlhash,"itemnumber","holdings");
-if ($itemnumber){
-NEWmoditem ( $dbh, $xmlhash, $biblionumber, $itemnumber);
-}else{
+Exported function (core API) for deleting an item record in Koha.
-##Add biblionumber to $record
-$xmlhash=XML_writeline($xmlhash,"biblionumber",$biblionumber,"holdings");
- my $sth=$dbh->prepare("select notforloan from itemtypes where itemtype='$itemtype'");
-$sth->execute();
-my $notforloan=$sth->fetchrow;
-##Change the notforloan field if $notforloan found
- if ($notforloan >0){
- $xmlhash=XML_writeline($xmlhash,"notforloan",$notforloan,"holdings");
- }
-my $dateaccessioned=XML_readline_onerecord($xmlhash,"dateaccessioned","holdings");
-unless($dateaccessioned){
-# find today's date
-my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
-localtime(time); $year +=1900; $mon +=1;
-my $date = "$year-".sprintf ("%0.2d", $mon)."-".sprintf("%0.2d",$mday);
+=cut
-$xmlhash=XML_writeline($xmlhash,"dateaccessioned",$date,"holdings");
+sub DelItem {
+ my ( $biblionumber, $itemnumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ &_koha_delete_item( $dbh, $itemnumber );
+ my $newrec = &MARCdelitem( $biblionumber, $itemnumber );
+ &MARCaddbiblio( $newrec, $biblionumber, MARCfind_frameworkcode($biblionumber) );
+ &logaction(C4::Context->userenv->{'number'},"CATALOGUING","DELETE",$itemnumber,"item")
+ if C4::Context->preference("CataloguingLog");
}
-## Now calculate itempart of cutter-- This is NEU specific
-my $itemcallnumber=XML_readline_onerecord($xmlhash,"itemcallnumber","holdings");
-if ($itemcallnumber){
-my ($cutterextra)=itemcalculator($dbh,$biblionumber,$itemcallnumber);
-$xmlhash=XML_writeline($xmlhash,"cutterextra",$cutterextra,"holdings");
-}
+=head2 GetBiblioData
-##NEU specific add cataloguers cardnumber as well
-my $me= C4::Context->userenv;
-my $cataloger=$me->{'cardnumber'} if ($me);
-$xmlhash=XML_writeline($xmlhash,"circid",$cataloger,"holdings") if $cataloger;
+ $data = &GetBiblioData($biblionumber, $type);
-##Add item to SQL
-my $itemnumber = &OLDnewitems( $dbh, $xmlhash );
+Returns information about the book with the given biblionumber.
-# add the item to zebra it will add the biblio as well!!!
- ZEBRAop( $dbh, $biblionumber,"specialUpdate","biblioserver" );
-return $itemnumber;
-}## added new item
+C<$type> is ignored.
-}
+C<&GetBiblioData> returns a reference-to-hash. The keys are the fields in
+the C<biblio> and C<biblioitems> tables in the
+Koha database.
+In addition, C<$data-E<gt>{subject}> is the list of the book's
+subjects, separated by C<" , "> (space, comma, space).
+If there are multiple biblioitems with the given biblionumber, only
+the first one is considered.
-sub NEWmoditem{
- my ( $dbh, $xmlhash, $biblionumber, $itemnumber ) = @_;
+=cut
-##Add itemnumber incase lost (old bug 090c was lost sometimes) --just incase
-$xmlhash=XML_writeline($xmlhash,"itemnumber",$itemnumber,"holdings");
-##Add biblionumber incase lost on html
-$xmlhash=XML_writeline($xmlhash,"biblionumber",$biblionumber,"holdings");
-##Read barcode
-my $barcode=XML_readline_onerecord($xmlhash,"barcode","holdings");
-## Now calculate itempart of cutter-- This is NEU specific
-my $itemcallnumber=XML_readline_onerecord($xmlhash,"itemcallnumber","holdings");
-if ($itemcallnumber){
-my ($cutterextra)=itemcalculator($dbh,$biblionumber,$itemcallnumber);
-$xmlhash=XML_writeline($xmlhash,"cutterextra",$cutterextra,"holdings");
-}
+#'
+sub GetBiblioData {
+ my ( $bibnum, $type ) = @_;
+ my $dbh = C4::Context->dbh;
-##NEU specific add cataloguers cardnumber as well
-my $me= C4::Context->userenv;
-my $cataloger=$me->{'cardnumber'} if ($me);
-$xmlhash=XML_writeline($xmlhash,"circid",$cataloger,"holdings") if $cataloger;
-my $xml=XML_hash2xml($xmlhash);
- OLDmoditem( $dbh, $xml,$biblionumber,$itemnumber,$barcode );
- ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
-}
+ my $query = "
+ SELECT * , biblioitems.notes AS bnotes, biblio.notes
+ FROM biblio
+ LEFT JOIN biblioitems ON biblio.biblionumber = biblioitems.biblionumber
+ LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
+ WHERE biblio.biblionumber = ?
+ AND biblioitems.biblionumber = biblio.biblionumber
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($bibnum);
+ my $data;
+ $data = $sth->fetchrow_hashref;
+ $sth->finish;
-sub NEWdelitem {
- my ( $dbh, $itemnumber ) = @_;
-my $sth=$dbh->prepare("SELECT biblionumber from items where itemnumber=?");
-$sth->execute($itemnumber);
-my $biblionumber=$sth->fetchrow;
-OLDdelitem( $dbh, $itemnumber ) ;
-ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
+ return ($data);
+} # sub GetBiblioData
-}
+=head2 GetItemsInfo
+ @results = &GetItemsInfo($biblionumber, $type);
+Returns information about books with the given biblionumber.
-sub NEWaddbiblio {
- my ( $dbh, $xmlhash,$frameworkcode ) = @_;
- my $sth = $dbh->prepare("Select max(biblionumber) from biblio");
- $sth->execute;
- my $data = $sth->fetchrow;
- my $biblionumber = $data + 1;
- $sth->finish;
- # we must add biblionumber
-my $record;
-$xmlhash=XML_writeline($xmlhash,"biblionumber",$biblionumber,"biblios");
-
-###NEU specific add cataloguers cardnumber as well
-
-my $me= C4::Context->userenv;
-my $cataloger=$me->{'cardnumber'} if ($me);
-$xmlhash=XML_writeline($xmlhash,"indexedby",$cataloger,"biblios") if $cataloger;
-
-## We must add the indexing fields for LC in MARC record--TG
-&XMLmodLCindex($dbh,$xmlhash);
-
-##Find itemtype
-my $itemtype=XML_readline_onerecord($xmlhash,"itemtype","biblios");
-##Find ISBN
-my $isbn=XML_readline_onerecord($xmlhash,"isbn","biblios");
-##Find ISSN
-my $issn=XML_readline_onerecord($xmlhash,"issn","biblios");
-##Find Title
-my $title=XML_readline_onerecord($xmlhash,"title","biblios");
-##Find Author
-my $author=XML_readline_onerecord($xmlhash,"title","biblios");
-my $xml=XML_hash2xml($xmlhash);
-
- $sth = $dbh->prepare("insert into biblio set biblionumber = ?,frameworkcode=?, itemtype=?,marcxml=?,title=?,author=?,isbn=?,issn=?" );
- $sth->execute( $biblionumber,$frameworkcode, $itemtype,$xml ,$title,$author,$isbn,$issn );
-
- $sth->finish;
-### Do not add biblio to ZEBRA unless there is an item with it -- depends on system preference defaults to NO
-if (C4::Context->preference('AddaloneBiblios')){
- ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
-}
- return ($biblionumber);
-}
+C<$type> may be either C<intra> or anything else. If it is not set to
+C<intra>, then the search will exclude lost, very overdue, and
+withdrawn items.
-sub NEWmodbiblio {
- my ( $dbh, $biblionumber,$xmlhash,$frameworkcode ) = @_;
-##Add biblionumber incase lost on html
+C<&GetItemsInfo> returns a list of references-to-hash. Each element
+contains a number of keys. Most of them are table items from the
+C<biblio>, C<biblioitems>, C<items>, and C<itemtypes> tables in the
+Koha database. Other keys include:
-$xmlhash=XML_writeline($xmlhash,"biblionumber",$biblionumber,"biblios");
+=over 4
-###NEU specific add cataloguers cardnumber as well
-my $me= C4::Context->userenv;
-my $cataloger=$me->{'cardnumber'} if ($me);
+=item C<$data-E<gt>{branchname}>
-$xmlhash=XML_writeline($xmlhash,"indexedby",$cataloger,"biblios") if $cataloger;
+The name (not the code) of the branch to which the book belongs.
-## We must add the indexing fields for LC in MARC record--TG
+=item C<$data-E<gt>{datelastseen}>
- XMLmodLCindex($dbh,$xmlhash);
- OLDmodbiblio ($dbh,$xmlhash,$biblionumber,$frameworkcode);
- my $ok=ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
- return ($biblionumber);
-}
+This is simply C<items.datelastseen>, except that while the date is
+stored in YYYY-MM-DD format in the database, here it is converted to
+DD/MM/YYYY format. A NULL date is returned as C<//>.
-#
-#
-# OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD
-#
-#
+=item C<$data-E<gt>{datedue}>
-sub OLDnewitems {
+=item C<$data-E<gt>{class}>
- my ( $dbh, $xmlhash) = @_;
- my $sth = $dbh->prepare("SELECT max(itemnumber) from items");
- my $data;
- my $itemnumber;
- $sth->execute;
- $data = $sth->fetchrow_hashref;
- $itemnumber = $data->{'max(itemnumber)'} + 1;
- $sth->finish;
- $xmlhash=XML_writeline( $xmlhash, "itemnumber", $itemnumber,"holdings" );
-my $biblionumber=XML_readline_onerecord($xmlhash,"biblionumber","holdings");
- my $barcode=XML_readline_onerecord($xmlhash,"barcode","holdings");
-my $xml=XML_hash2xml($xmlhash);
- $sth = $dbh->prepare( "Insert into items set itemnumber = ?, biblionumber = ?,barcode = ?,marcxml=?" );
- $sth->execute($itemnumber,$biblionumber,$barcode,$xml);
- return $itemnumber;
-}
+This is the concatenation of C<biblioitems.classification>, the book's
+Dewey code, and C<biblioitems.subclass>.
-sub OLDmoditem {
- my ( $dbh, $xml,$biblionumber,$itemnumber,$barcode ) = @_;
- my $sth =$dbh->prepare("replace items set biblionumber=?,marcxml=?,barcode=? , itemnumber=?");
- $sth->execute($biblionumber,$xml,$barcode,$itemnumber);
- $sth->finish;
-}
+=item C<$data-E<gt>{ocount}>
-sub OLDdelitem {
- my ( $dbh, $itemnumber ) = @_;
-my $sth = $dbh->prepare("select * from items where itemnumber=?");
- $sth->execute($itemnumber);
- if ( my $data = $sth->fetchrow_hashref ) {
- $sth->finish;
- my $query = "replace deleteditems set ";
- my @bind = ();
- foreach my $temp ( keys %$data ) {
- $query .= "$temp = ?,";
- push ( @bind, $data->{$temp} );
- }
+I think this is the number of copies of the book available.
- #replacing the last , by ",?)"
- $query =~ s/\,$//;
- $sth = $dbh->prepare($query);
- $sth->execute(@bind);
- $sth->finish;
- $sth = $dbh->prepare("Delete from items where itemnumber=?");
- $sth->execute($itemnumber);
- $sth->finish;
- }
- $sth->finish;
-}
+=item C<$data-E<gt>{order}>
-sub OLDmodbiblio {
-# modifies the biblio table
-my ($dbh,$xmlhash,$biblionumber,$frameworkcode) = @_;
- if (!$frameworkcode){
- $frameworkcode="";
- }
-##Find itemtype
-my $itemtype=XML_readline_onerecord($xmlhash,"itemtype","biblios");
-##Find ISBN
-my $isbn=XML_readline_onerecord($xmlhash,"isbn","biblios");
-##Find ISSN
-my $issn=XML_readline_onerecord($xmlhash,"issn","biblios");
-##Find Title
-my $title=XML_readline_onerecord($xmlhash,"title","biblios");
-##Find Author
-my $author=XML_readline_onerecord($xmlhash,"author","biblios");
-my $xml=XML_hash2xml($xmlhash);
-
-$isbn=~ s/(\.|\?|\;|\=|\-|\/|\\|\||\:|\*|\!|\,|\(|\)|\[|\]|\{|\}|\/)//g;
-$issn=~ s/(\.|\?|\;|\=|\-|\/|\\|\||\:|\*|\!|\,|\(|\)|\[|\]|\{|\}|\/)//g;
-$isbn=~s/^\s+|\s+$//g;
-$isbn=substr($isbn,0,13);
- my $sth = $dbh->prepare("REPLACE biblio set biblionumber=?,marcxml=?,frameworkcode=? ,itemtype=? , title=?,author=?,isbn=?,issn=?" );
- $sth->execute( $biblionumber ,$xml, $frameworkcode,$itemtype, $title,$author,$isbn,$issn);
- $sth->finish;
- return $biblionumber;
-}
+If this is set, it is set to C<One Order>.
-sub OLDdelbiblio {
- my ( $dbh, $biblionumber ) = @_;
- my $sth = $dbh->prepare("select * from biblio where biblionumber=?");
+=back
+
+=cut
+
+#'
+sub GetItemsInfo {
+ my ( $biblionumber, $type ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "SELECT *,items.notforloan as itemnotforloan
+ FROM items, biblio, biblioitems
+ LEFT JOIN itemtypes on biblioitems.itemtype = itemtypes.itemtype
+ WHERE items.biblionumber = ?
+ AND biblioitems.biblioitemnumber = items.biblioitemnumber
+ AND biblio.biblionumber = items.biblionumber
+ ORDER BY items.dateaccessioned desc
+ ";
+ my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
- if ( my $data = $sth->fetchrow_hashref ) {
- $sth->finish;
- my $query = "replace deletedbiblio set ";
- my @bind = ();
- foreach my $temp ( keys %$data ) {
- $query .= "$temp = ?,";
- push ( @bind, $data->{$temp} );
+ my $i = 0;
+ my @results;
+ my ( $date_due, $count_reserves );
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ my $datedue = '';
+ my $isth = $dbh->prepare(
+ "SELECT issues.*,borrowers.cardnumber
+ FROM issues, borrowers
+ WHERE itemnumber = ?
+ AND returndate IS NULL
+ AND issues.borrowernumber=borrowers.borrowernumber"
+ );
+ $isth->execute( $data->{'itemnumber'} );
+ if ( my $idata = $isth->fetchrow_hashref ) {
+ $data->{borrowernumber} = $idata->{borrowernumber};
+ $data->{cardnumber} = $idata->{cardnumber};
+ $datedue = format_date( $idata->{'date_due'} );
+ }
+ if ( $datedue eq '' ) {
+ #$datedue="Available";
+ my ( $restype, $reserves ) =
+ C4::Reserves2::CheckReserves( $data->{'itemnumber'} );
+ if ($restype) {
+
+ #$datedue=$restype;
+ $count_reserves = $restype;
+ }
+ }
+ $isth->finish;
+
+ #get branch information.....
+ my $bsth = $dbh->prepare(
+ "SELECT * FROM branches WHERE branchcode = ?
+ "
+ );
+ $bsth->execute( $data->{'holdingbranch'} );
+ if ( my $bdata = $bsth->fetchrow_hashref ) {
+ $data->{'branchname'} = $bdata->{'branchname'};
+ }
+ my $date = format_date( $data->{'datelastseen'} );
+ $data->{'datelastseen'} = $date;
+ $data->{'datedue'} = $datedue;
+ $data->{'count_reserves'} = $count_reserves;
+
+ # get notforloan complete status if applicable
+ my $sthnflstatus = $dbh->prepare(
+ 'SELECT authorised_value
+ FROM marc_subfield_structure
+ WHERE kohafield="items.notforloan"
+ '
+ );
+
+ $sthnflstatus->execute;
+ my ($authorised_valuecode) = $sthnflstatus->fetchrow;
+ if ($authorised_valuecode) {
+ $sthnflstatus = $dbh->prepare(
+ "SELECT lib FROM authorised_values
+ WHERE category=?
+ AND authorised_value=?"
+ );
+ $sthnflstatus->execute( $authorised_valuecode,
+ $data->{itemnotforloan} );
+ my ($lib) = $sthnflstatus->fetchrow;
+ $data->{notforloan} = $lib;
}
- #replacing the last , by ",?)"
- $query =~ s/\,$//;
- $sth = $dbh->prepare($query);
- $sth->execute(@bind);
- $sth->finish;
- $sth = $dbh->prepare("Delete from biblio where biblionumber=?");
- $sth->execute($biblionumber);
- $sth->finish;
+ # my stack procedures
+ my $stackstatus = $dbh->prepare(
+ 'SELECT authorised_value
+ FROM marc_subfield_structure
+ WHERE kohafield="items.stack"
+ '
+ );
+ $stackstatus->execute;
+
+ ($authorised_valuecode) = $stackstatus->fetchrow;
+ if ($authorised_valuecode) {
+ $stackstatus = $dbh->prepare(
+ "SELECT lib
+ FROM authorised_values
+ WHERE category=?
+ AND authorised_value=?
+ "
+ );
+ $stackstatus->execute( $authorised_valuecode, $data->{stack} );
+ my ($lib) = $stackstatus->fetchrow;
+ $data->{stack} = $lib;
+ }
+ $results[$i] = $data;
+ $i++;
}
$sth->finish;
+
+ return (@results);
}
+=head2 getitemstatus
-#
-#
-#
-#ZEBRA ZEBRA ZEBRA
-#
-#
+ $itemstatushash = &getitemstatus($fwkcode);
+ returns information about status.
+ Can be MARC dependant.
+ fwkcode is optional.
+ But basically could be can be loan or not
+ Create a status selector with the following code
-sub ZEBRAdelbiblio {
-## Zebra calls this routine to delete after it deletes biblio from ZEBRAddb
- my ( $dbh, $biblionumber ) = @_;
-my $sth=$dbh->prepare("SELECT itemnumber FROM items where biblionumber=?");
+=head3 in PERL SCRIPT
-$sth->execute($biblionumber);
- while (my $itemnumber =$sth->fetchrow){
- OLDdelitem($dbh,$itemnumber) ;
- }
-OLDdelbiblio($dbh,$biblionumber) ;
-}
-
-sub ZEBRAgetrecord{
-my $biblionumber=shift;
-my @kohafield="biblionumber";
-my @value=$biblionumber;
-my ($count, at result)=C4::Search::ZEBRAsearch_kohafields(\@kohafield,\@value);
-
- if ($count>0){
- my ( $xmlrecord, @itemsrecord) = XML_separate($result[0]);
- return ($xmlrecord, @itemsrecord);
- }else{
- return (undef,undef);
- }
+my $itemstatushash = getitemstatus;
+my @itemstatusloop;
+foreach my $thisstatus (keys %$itemstatushash) {
+ my %row =(value => $thisstatus,
+ statusname => $itemstatushash->{$thisstatus}->{'statusname'},
+ );
+ push @itemstatusloop, \%row;
}
+$template->param(statusloop=>\@itemstatusloop);
-sub ZEBRAop {
-### Puts the zebra update in queue writes in zebraserver table
-my ($dbh,$biblionumber,$op,$server)=@_;
-if (!$biblionumber){
-warn "Zebra received no biblionumber";
-}elsif (C4::Context->preference('onlineZEBRA')){
-my $marcxml;
- if ($server eq "biblioserver"){
- ($marcxml) =ZEBRA_readyXML($dbh,$biblionumber);
- }elsif($server eq "authorityserver"){
- $marcxml =C4::AuthoritiesMarc::XMLgetauthority($dbh,$biblionumber);
- }
-ZEBRAopserver($marcxml,$op,$server,$biblionumber);
-ZEBRAopcommit($server);
-}else{
-my $sth=$dbh->prepare("insert into zebraqueue (biblio_auth_number ,server,operation) values(?,?,?)");
-$sth->execute($biblionumber,$server,$op);
-$sth->finish;
-}
-}
+=head3 in TEMPLATE
+ <select name="statusloop">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="statusloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="statusname" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
-sub ZEBRAopserver{
+=cut
-###Accepts a $server variable thus we can use it to update biblios, authorities or other zebra dbs
-my ($record,$op,$server,$biblionumber)=@_;
+sub GetItemStatus {
-my @port;
+ # returns a reference to a hash of references to status...
+ my ($fwk) = @_;
+ my %itemstatus;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ $fwk = '' unless ($fwk);
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.notforloan", $fwk );
+ if ( $tag and $subfield ) {
+ my $sth =
+ $dbh->prepare(
+"select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?"
+ );
+ $sth->execute( $tag, $subfield, $fwk );
+ if ( my ($authorisedvaluecat) = $sth->fetchrow ) {
+ my $authvalsth =
+ $dbh->prepare(
+"select authorised_value, lib from authorised_values where category=? order by lib"
+ );
+ $authvalsth->execute($authorisedvaluecat);
+ while ( my ( $authorisedvalue, $lib ) = $authvalsth->fetchrow ) {
+ $itemstatus{$authorisedvalue} = $lib;
+ }
+ $authvalsth->finish;
+ return \%itemstatus;
+ exit 1;
+ }
+ else {
-my $tried=0;
-my $recon=0;
-my $reconnect=0;
-$record=Encode::encode("UTF-8",$record);
-my $shadow=$server."shadow";
-reconnect:
-
- my $Zconnbiblio=C4::Context->Zconnauth($server);
-if ($record){
-my $Zpackage = $Zconnbiblio->package();
-$Zpackage->option(action => $op);
- $Zpackage->option(record => $record);
- $Zpackage->option(recordIdOpaque => $biblionumber);
-retry:
- $Zpackage->send("update");
-
- my($error, $errmsg, $addinfo, $diagset) = $Zconnbiblio->error_x();
- if ($error==10007 && $tried<3) {## timeout --another 30 looonng seconds for this update
- sleep 1; ## wait a sec!
- $tried=$tried+1;
- goto "retry";
- }elsif ($error==2 && $tried<2) {## timeout --temporary zebra error !whatever that means
- sleep 2; ## wait two seconds!
- $tried=$tried+1;
- goto "retry";
- }elsif($error==10004 && $recon==0){##Lost connection -reconnect
- sleep 1; ## wait a sec!
- $recon=1;
- $Zpackage->destroy();
- $Zconnbiblio->destroy();
- goto "reconnect";
- }elsif ($error){
- # warn "Error-$server $op /errcode:, $error, /MSG:,$errmsg,$addinfo \n";
- $Zpackage->destroy();
- $Zconnbiblio->destroy();
- return 0;
+ #No authvalue list
+ # build default
+ }
+ $sth->finish;
}
-$Zpackage->destroy();
-$Zconnbiblio->destroy();
-return 1;
-}
-return 0;
+ #No authvalue list
+ #build default
+ $itemstatus{"1"} = "Not For Loan";
+ return \%itemstatus;
+}
+
+=head2 getitemlocation
+
+ $itemlochash = &getitemlocation($fwk);
+ returns informations about location.
+ where fwk stands for an optional framework code.
+ Create a location selector with the following code
+
+=head3 in PERL SCRIPT
+
+my $itemlochash = getitemlocation;
+my @itemlocloop;
+foreach my $thisloc (keys %$itemlochash) {
+ my $selected = 1 if $thisbranch eq $branch;
+ my %row =(locval => $thisloc,
+ selected => $selected,
+ locname => $itemlochash->{$thisloc},
+ );
+ push @itemlocloop, \%row;
}
+$template->param(itemlocationloop => \@itemlocloop);
+=head3 in TEMPLATE
+ <select name="location">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="itemlocationloop" -->
+ <option value="<!-- TMPL_VAR name="locval" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="locname" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
-sub ZEBRAopcommit {
-my $server=shift;
-return unless C4::Context->config($server."shadow");
-my $Zconnbiblio=C4::Context->Zconnauth($server);
+=cut
-my $Zpackage = $Zconnbiblio->package();
- $Zpackage->send('commit');
+sub GetItemLocation {
- my($error, $errmsg, $addinfo, $diagset) = $Zconnbiblio->error_x();
- if ($error) { ## This is serious ZEBRA server is not updating
- $Zpackage->destroy();
- $Zconnbiblio->destroy();
- return 0;
- }
-$Zpackage->destroy();
-$Zconnbiblio->destroy();
-return 1;
-}
-sub ZEBRA_readyXML{
-my ($dbh,$biblionumber)=@_;
-my $biblioxml=XMLgetbiblio($dbh,$biblionumber);
-my @itemxml=XMLgetallitems($dbh,$biblionumber);
-my $zebraxml=collection_header();
-$zebraxml.="<koharecord>";
-$zebraxml.=$biblioxml;
-$zebraxml.="<holdings>";
- foreach my $item(@itemxml){
- $zebraxml.=$item if $item;
+ # returns a reference to a hash of references to location...
+ my ($fwk) = @_;
+ my %itemlocation;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ $fwk = '' unless ($fwk);
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.location", $fwk );
+ if ( $tag and $subfield ) {
+ my $sth =
+ $dbh->prepare(
+"select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?"
+ );
+ $sth->execute( $tag, $subfield, $fwk );
+ if ( my ($authorisedvaluecat) = $sth->fetchrow ) {
+ my $authvalsth =
+ $dbh->prepare(
+"select authorised_value, lib from authorised_values where category=? order by lib"
+ );
+ $authvalsth->execute($authorisedvaluecat);
+ while ( my ( $authorisedvalue, $lib ) = $authvalsth->fetchrow ) {
+ $itemlocation{$authorisedvalue} = $lib;
+ }
+ $authvalsth->finish;
+ return \%itemlocation;
+ exit 1;
}
-$zebraxml.="</holdings>";
-$zebraxml.="</koharecord>";
-$zebraxml.="</kohacollection>";
-return $zebraxml;
-}
+ else {
-sub ZEBRA_readyXML_noheader{
-my ($dbh,$biblionumber)=@_;
-my $biblioxml=XMLgetbiblio($dbh,$biblionumber);
-my @itemxml=XMLgetallitems($dbh,$biblionumber);
-my $zebraxml="<koharecord>";
-$zebraxml.=$biblioxml;
-$zebraxml.="<holdings>";
- foreach my $item(@itemxml){
- $zebraxml.=$item if $item;
+ #No authvalue list
+ # build default
+ }
+ $sth->finish;
}
-$zebraxml.="</holdings>";
-$zebraxml.="</koharecord>";
-return $zebraxml;
+
+ #No authvalue list
+ #build default
+ $itemlocation{"1"} = "Not For Loan";
+ return \%itemlocation;
}
-#
-#
-# various utility subs and those not complying to new rules
-#
-#
+=head2 &GetBiblioItemData
-sub newbiblio {
-## Used in acqui management -- creates the biblio from koha hash
- my ($biblio) = @_;
+ $itemdata = &GetBiblioItemData($biblioitemnumber);
+
+Looks up the biblioitem with the given biblioitemnumber. Returns a
+reference-to-hash. The keys are the fields from the C<biblio>,
+C<biblioitems>, and C<itemtypes> tables in the Koha database, except
+that C<biblioitems.notes> is given as C<$itemdata-E<gt>{bnotes}>.
+
+=cut
+
+#'
+sub GetBiblioItemData {
+ my ($bibitem) = @_;
my $dbh = C4::Context->dbh;
-my $record=XMLkoha2marc($dbh,$biblio,"biblios");
- my $biblionumber=NEWnewbiblio($dbh,$record);
- return ($biblionumber);
-}
-sub modbiblio {
-## Used in acqui management -- modifies the biblio from koha hash rather than xml-hash
- my ($biblio) = @_;
+ my $sth =
+ $dbh->prepare(
+"Select *,biblioitems.notes as bnotes from biblioitems, biblio,itemtypes where biblio.biblionumber = biblioitems.biblionumber and biblioitemnumber = ? and biblioitems.itemtype = itemtypes.itemtype"
+ );
+ my $data;
+
+ $sth->execute($bibitem);
+
+ $data = $sth->fetchrow_hashref;
+
+ $sth->finish;
+ return ($data);
+} # sub &GetBiblioItemData
+
+=head2 GetItemFromBarcode
+
+$result = GetItemFromBarcode($barcode);
+
+=cut
+
+sub GetItemFromBarcode {
+ my ($barcode) = @_;
my $dbh = C4::Context->dbh;
-my $record=XMLkoha2marc($dbh,$biblio,"biblios");
- my $biblionumber=NEWmodbiblio($dbh,$record,$biblio->{biblionumber});
- return ($biblionumber);
+
+ my $rq =
+ $dbh->prepare("SELECT itemnumber from items where items.barcode=?");
+ $rq->execute($barcode);
+ my ($result) = $rq->fetchrow;
+ return ($result);
}
-sub newitems {
-## Used in acqui management -- creates the item from hash rather than marc-record
- my ( $item, @barcodes ) = @_;
+=head2 GetBiblioItemByBiblioNumber
+
+NOTE : This function has been copy/paste from C4/Biblio.pm from head before zebra integration.
+
+=cut
+
+sub GetBiblioItemByBiblioNumber {
+ my ($biblionumber) = @_;
my $dbh = C4::Context->dbh;
- my $errors;
- my $itemnumber;
- my $error;
- foreach my $barcode (@barcodes) {
- $item->{barcode}=$barcode;
-my $record=MARCkoha2marc($dbh,$item,"holdings");
- my $itemnumber= NEWnewitem($dbh,$record,$item->{biblionumber});
+ my $sth = $dbh->prepare("Select * from biblioitems where biblionumber = ?");
+ my $count = 0;
+ my @results;
+
+ $sth->execute($biblionumber);
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
}
- return $itemnumber ;
+
+ $sth->finish;
+ return @results;
}
+=head2 GetBiblioFromItemNumber
+ $item = &GetBiblioFromItemNumber($itemnumber);
+Looks up the item with the given itemnumber.
-sub getitemtypes {
+C<&itemnodata> returns a reference-to-hash whose keys are the fields
+from the C<biblio>, C<biblioitems>, and C<items> tables in the Koha
+database.
+
+=cut
+
+#'
+sub GetBiblioFromItemNumber {
+ my ( $itemnumber ) = @_;
my $dbh = C4::Context->dbh;
- my $query = "select * from itemtypes order by description";
- my $sth = $dbh->prepare($query);
+ my $env;
+ my $sth = $dbh->prepare(
+ "SELECT * FROM biblio,items,biblioitems
+ WHERE items.itemnumber = ?
+ AND biblio.biblionumber = items.biblionumber
+ AND biblioitems.biblioitemnumber = items.biblioitemnumber"
+ );
+
+ $sth->execute($itemnumber);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return ($data);
+}
+
+=head2 GetBiblio
+
+( $count, @results ) = &GetBiblio($biblionumber);
+
+=cut
+
+sub GetBiblio {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("Select * from biblio where biblionumber = ?");
+ my $count = 0;
+ my @results;
+ $sth->execute($biblionumber);
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $results[$count] = $data;
+ $count++;
+ } # while
+ $sth->finish;
+ return ( $count, @results );
+} # sub GetBiblio
+
+=head2 getitemsbybiblioitem
+
+( $count, @results ) = &getitemsbybiblioitem($biblioitemnum);
+
+=cut
+
+sub getitemsbybiblioitem {
+ my ($biblioitemnum) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "Select * from items, biblio where
+biblio.biblionumber = items.biblionumber and biblioitemnumber
+= ?"
+ );
- # || die "Cannot prepare $query" . $dbh->errstr;
+ # || die "Cannot prepare $query\n" . $dbh->errstr;
my $count = 0;
my @results;
- $sth->execute;
+
+ $sth->execute($biblioitemnum);
+
# || die "Cannot execute $query\n" . $sth->errstr;
while ( my $data = $sth->fetchrow_hashref ) {
$results[$count] = $data;
@@ -1383,149 +1039,2907 @@
$sth->finish;
return ( $count, @results );
-} # sub getitemtypes
+} # sub getitemsbybiblioitem
+=head2 get_itemnumbers_of
+ my @itemnumbers_of = get_itemnumbers_of(@biblionumbers);
-sub getkohafields{
-#returns MySQL like fieldnames to emulate searches on sql like fieldnames
-my $type=shift;
-## Either opac or intranet to select appropriate fields
-## Assumes intranet
-$type="intra" unless $type;
-if ($type eq "intranet"){ $type="intra";}
-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 label");
-$sth->execute();
-while (my $data=$sth->fetchrow_hashref){
- $results[$i]=$data;
- $i++;
- }
-$sth->finish;
-return ($i, at results);
-}
+Given a list of biblionumbers, return the list of corresponding itemnumbers
+for each biblionumber.
+Return a reference on a hash where keys are biblionumbers and values are
+references on array of itemnumbers.
+=cut
+sub get_itemnumbers_of {
+ my @biblionumbers = @_;
+ my $dbh = C4::Context->dbh;
-sub DisplayISBN {
-## Old style ISBN handling should be modified to accept 13 digits
-
- my ($isbn)=@_;
- my $seg1;
- if(substr($isbn, 0, 1) <=7) {
- $seg1 = substr($isbn, 0, 1);
- } elsif(substr($isbn, 0, 2) <= 94) {
- $seg1 = substr($isbn, 0, 2);
- } elsif(substr($isbn, 0, 3) <= 995) {
- $seg1 = substr($isbn, 0, 3);
- } elsif(substr($isbn, 0, 4) <= 9989) {
- $seg1 = substr($isbn, 0, 4);
- } else {
- $seg1 = substr($isbn, 0, 5);
- }
- my $x = substr($isbn, length($seg1));
- my $seg2;
- if(substr($x, 0, 2) <= 19) {
-# if(sTmp2 < 10) sTmp2 = "0" sTmp2;
- $seg2 = substr($x, 0, 2);
- } elsif(substr($x, 0, 3) <= 699) {
- $seg2 = substr($x, 0, 3);
- } elsif(substr($x, 0, 4) <= 8399) {
- $seg2 = substr($x, 0, 4);
- } elsif(substr($x, 0, 5) <= 89999) {
- $seg2 = substr($x, 0, 5);
- } elsif(substr($x, 0, 6) <= 9499999) {
- $seg2 = substr($x, 0, 6);
- } else {
- $seg2 = substr($x, 0, 7);
- }
- my $seg3=substr($x,length($seg2));
- $seg3=substr($seg3,0,length($seg3)-1) ;
- my $seg4 = substr($x, -1, 1);
- return "$seg1-$seg2-$seg3-$seg4";
-}
-sub calculatelc{
-## Function to create padded LC call number for sorting items with their LC code. Not exported
-my ($classification)=@_;
-$classification=~s/^\s+|\s+$//g;
-my $i=0;
-my $lc2;
-my $lc1;
-for ($i=0; $i<length($classification);$i++){
-my $c=(substr($classification,$i,1));
- if ($c ge '0' && $c le '9'){
+ my $query = '
+ SELECT itemnumber,
+ biblionumber
+ FROM items
+ WHERE biblionumber IN (?' . ( ',?' x scalar @biblionumbers - 1 ) . ')
+ ';
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@biblionumbers);
- $lc2=substr($classification,$i);
- last;
- }else{
- $lc1.=substr($classification,$i,1);
+ my %itemnumbers_of;
+ while ( my ( $itemnumber, $biblionumber ) = $sth->fetchrow_array ) {
+ push @{ $itemnumbers_of{$biblionumber} }, $itemnumber;
}
-}#while
-my $other=length($lc1);
-if(!$lc1){$other=0;}
-my $extras;
-if ($other<4){
- for (1..(4-$other)){
- $extras.="0";
- }
+ return \%itemnumbers_of;
}
- $lc1.=$extras;
-$lc2=~ s/^ //g;
-$lc2=~ s/ //g;
-$extras="";
-##Find the decimal part of $lc2
-my $pos=index($lc2,".");
-if ($pos<0){$pos=length($lc2);}
-if ($pos>=0 && $pos<5){
-##Pad lc2 with zeros to create a 5digit decimal needed in marc record to sort as numeric
+=head2 getRecord
- for (1..(5-$pos)){
- $extras.="0";
- }
-}
-$lc2=$extras.$lc2;
-return($lc1.$lc2);
-}
+$record = getRecord( $server, $koha_query, $recordSyntax );
-sub itemcalculator{
-## Sublimentary function to obtain sorted LC for items. Not exported
-my ($dbh,$biblionumber,$callnumber)=@_;
-my $xmlhash=XMLgetbibliohash($dbh,$biblionumber);
-my $lc=XML_readline_onerecord($xmlhash,"classification","biblios");
-my $cutter=XML_readline_onerecord($xmlhash,"subclass","biblios");
-my $all=$lc." ".$cutter;
-my $total=length($all);
-my $cutterextra=substr($callnumber,$total);
-return $cutterextra;
+get a single record in piggyback mode from Zebra and return it in the requested record syntax
-}
+default record syntax is XML
+=cut
-#### This function allows decoding of only title and author out of a MARC record
- sub func_title_author {
- my ($tagno,$tagdata) = @_;
- my ($titlef,$subf)=&MARCfind_marc_from_kohafield("title","biblios");
- my ($authf,$subf)=&MARCfind_marc_from_kohafield("author","biblios");
- return ($tagno == $titlef || $tagno == $authf);
+sub getRecord {
+ my ( $server, $koha_query, $recordSyntax ) = @_;
+ $recordSyntax = "xml" unless $recordSyntax;
+ my $Zconn = C4::Context->Zconn( $server, 0, 1, 1, $recordSyntax );
+ my $rs = $Zconn->search( new ZOOM::Query::CCL2RPN( $koha_query, $Zconn ) );
+ if ( $rs->record(0) ) {
+ return $rs->record(0)->raw();
}
+}
+=head2 GetItemInfosOf
+GetItemInfosOf(@itemnumbers);
+
+=cut
+
+sub GetItemInfosOf {
+ my @itemnumbers = @_;
+
+ my $query = '
+ SELECT *
+ FROM items
+ WHERE itemnumber IN (' . join( ',', @itemnumbers ) . ')
+ ';
+ return get_infos_of( $query, 'itemnumber' );
+}
+
+=head2 GetBiblioItemInfosOf
+
+GetBiblioItemInfosOf(@biblioitemnumbers);
+
+=cut
+
+sub GetBiblioItemInfosOf {
+ my @biblioitemnumbers = @_;
+
+ my $query = '
+ SELECT biblioitemnumber,
+ publicationyear,
+ itemtype
+ FROM biblioitems
+ WHERE biblioitemnumber IN (' . join( ',', @biblioitemnumbers ) . ')
+ ';
+ return get_infos_of( $query, 'biblioitemnumber' );
+}
+
+=head2 z3950_extended_services
+
+z3950_extended_services($serviceType,$serviceOptions,$record);
+
+ z3950_extended_services is used to handle all interactions with Zebra's extended serices package, which is employed to perform all management of the MARC data stored in Zebra.
+
+C<$serviceType> one of: itemorder,create,drop,commit,update,xmlupdate
+
+C<$serviceOptions> a has of key/value pairs. For instance, if service_type is 'update', $service_options should contain:
+
+ action => update action, one of specialUpdate, recordInsert, recordReplace, recordDelete, elementUpdate.
+
+and maybe
+
+ recordidOpaque => Opaque Record ID (user supplied) or recordidNumber => Record ID number (system number).
+ syntax => the record syntax (transfer syntax)
+ databaseName = Database from connection object
+
+ To set serviceOptions, call set_service_options($serviceType)
+
+C<$record> the record, if one is needed for the service type
+
+ A record should be in XML. You can convert it to XML from MARC by running it through marc2xml().
+
+=cut
+
+sub z3950_extended_services {
+ my ( $server, $serviceType, $action, $serviceOptions ) = @_;
+
+ # get our connection object
+ my $Zconn = C4::Context->Zconn( $server, 0, 1 );
+
+ # create a new package object
+ my $Zpackage = $Zconn->package();
+
+ # set our options
+ $Zpackage->option( action => $action );
+
+ if ( $serviceOptions->{'databaseName'} ) {
+ $Zpackage->option( databaseName => $serviceOptions->{'databaseName'} );
+ }
+ if ( $serviceOptions->{'recordIdNumber'} ) {
+ $Zpackage->option(
+ recordIdNumber => $serviceOptions->{'recordIdNumber'} );
+ }
+ if ( $serviceOptions->{'recordIdOpaque'} ) {
+ $Zpackage->option(
+ recordIdOpaque => $serviceOptions->{'recordIdOpaque'} );
+ }
+
+ # this is an ILL request (Zebra doesn't support it, but Koha could eventually)
+ #if ($serviceType eq 'itemorder') {
+ # $Zpackage->option('contact-name' => $serviceOptions->{'contact-name'});
+ # $Zpackage->option('contact-phone' => $serviceOptions->{'contact-phone'});
+ # $Zpackage->option('contact-email' => $serviceOptions->{'contact-email'});
+ # $Zpackage->option('itemorder-item' => $serviceOptions->{'itemorder-item'});
+ #}
+
+ if ( $serviceOptions->{record} ) {
+ $Zpackage->option( record => $serviceOptions->{record} );
+
+ # can be xml or marc
+ if ( $serviceOptions->{'syntax'} ) {
+ $Zpackage->option( syntax => $serviceOptions->{'syntax'} );
+ }
+ }
+
+ # send the request, handle any exception encountered
+ eval { $Zpackage->send($serviceType) };
+ if ( $@ && $@->isa("ZOOM::Exception") ) {
+ return "error: " . $@->code() . " " . $@->message() . "\n";
+ }
+
+ # free up package resources
+ $Zpackage->destroy();
+}
+
+=head2 set_service_options
+
+my $serviceOptions = set_service_options($serviceType);
+
+C<$serviceType> itemorder,create,drop,commit,update,xmlupdate
+
+Currently, we only support 'create', 'commit', and 'update'. 'drop' support will be added as soon as Zebra supports it.
+
+=cut
+
+sub set_service_options {
+ my ($serviceType) = @_;
+ my $serviceOptions;
+
+# FIXME: This needs to be an OID ... if we ever need 'syntax' this sub will need to change
+# $serviceOptions->{ 'syntax' } = ''; #zebra doesn't support syntaxes other than xml
+
+ if ( $serviceType eq 'commit' ) {
+
+ # nothing to do
+ }
+ if ( $serviceType eq 'create' ) {
+
+ # nothing to do
+ }
+ if ( $serviceType eq 'drop' ) {
+ die "ERROR: 'drop' not currently supported (by Zebra)";
+ }
+ return $serviceOptions;
+}
+
+=head1 FUNCTIONS FOR HANDLING MARC MANAGEMENT
+
+=head2 MARCgettagslib
+
+=cut
+
+sub MARCgettagslib {
+ my ( $dbh, $forlibrarian, $frameworkcode ) = @_;
+ $frameworkcode = "" unless $frameworkcode;
+ my $sth;
+ my $libfield = ( $forlibrarian eq 1 ) ? 'liblibrarian' : 'libopac';
+
+ # check that framework exists
+ $sth =
+ $dbh->prepare(
+ "select count(*) from marc_tag_structure where frameworkcode=?");
+ $sth->execute($frameworkcode);
+ my ($total) = $sth->fetchrow;
+ $frameworkcode = "" unless ( $total > 0 );
+ $sth =
+ $dbh->prepare(
+"select tagfield,liblibrarian,libopac,mandatory,repeatable from marc_tag_structure where frameworkcode=? order by tagfield"
+ );
+ $sth->execute($frameworkcode);
+ my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable );
+
+ while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) =
+ $sth->fetchrow )
+ {
+ $res->{$tag}->{lib} =
+ ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
+ $res->{$tab}->{tab} = ""; # XXX
+ $res->{$tag}->{mandatory} = $mandatory;
+ $res->{$tag}->{repeatable} = $repeatable;
+ }
+
+ $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,kohafield,seealso,hidden,isurl,link from marc_subfield_structure where frameworkcode=? order by tagfield,tagsubfield"
+ );
+ $sth->execute($frameworkcode);
+
+ my $subfield;
+ my $authorised_value;
+ my $authtypecode;
+ my $value_builder;
+ my $kohafield;
+ my $seealso;
+ my $hidden;
+ my $isurl;
+ my $link;
+
+ while (
+ (
+ $tag, $subfield, $liblibrarian,
+ , $libopac, $tab,
+ $mandatory, $repeatable, $authorised_value,
+ $authtypecode, $value_builder, $kohafield,
+ $seealso, $hidden, $isurl,
+ $link
+ )
+ = $sth->fetchrow
+ )
+ {
+ $res->{$tag}->{$subfield}->{lib} =
+ ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
+ $res->{$tag}->{$subfield}->{tab} = $tab;
+ $res->{$tag}->{$subfield}->{mandatory} = $mandatory;
+ $res->{$tag}->{$subfield}->{repeatable} = $repeatable;
+ $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
+ $res->{$tag}->{$subfield}->{authtypecode} = $authtypecode;
+ $res->{$tag}->{$subfield}->{value_builder} = $value_builder;
+ $res->{$tag}->{$subfield}->{kohafield} = $kohafield;
+ $res->{$tag}->{$subfield}->{seealso} = $seealso;
+ $res->{$tag}->{$subfield}->{hidden} = $hidden;
+ $res->{$tag}->{$subfield}->{isurl} = $isurl;
+ $res->{$tag}->{$subfield}->{link} = $link;
+ }
+ return $res;
+}
+
+=head2 MARCfind_marc_from_kohafield
+
+=cut
+
+sub MARCfind_marc_from_kohafield {
+ my ( $dbh, $kohafield, $frameworkcode ) = @_;
+ return 0, 0 unless $kohafield;
+ my $relations = C4::Context->marcfromkohafield;
+ return (
+ $relations->{$frameworkcode}->{$kohafield}->[0],
+ $relations->{$frameworkcode}->{$kohafield}->[1]
+ );
+}
+
+=head2 MARCaddbiblio
+
+&MARCaddbiblio($newrec,$biblionumber,$frameworkcode);
+
+Add MARC data for a biblio to koha
+
+=cut
+
+sub MARCaddbiblio {
+
+# pass the MARC::Record to this function, and it will create the records in the marc tables
+ my ( $record, $biblionumber, $frameworkcode ) = @_;
+ my $dbh = C4::Context->dbh;
+ my @fields = $record->fields();
+ if ( !$frameworkcode ) {
+ $frameworkcode = "";
+ }
+ my $sth =
+ $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
+ $sth->execute( $frameworkcode, $biblionumber );
+ $sth->finish;
+ my $encoding = C4::Context->preference("marcflavour");
+
+# deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
+ if ( $encoding eq "UNIMARC" ) {
+ my $string;
+ if ( $record->subfield( 100, "a" ) ) {
+ $string = $record->subfield( 100, "a" );
+ my $f100 = $record->field(100);
+ $record->delete_field($f100);
+ }
+ else {
+ $string = POSIX::strftime( "%Y%m%d", localtime );
+ $string =~ s/\-//g;
+ $string = sprintf( "%-*s", 35, $string );
+ }
+ substr( $string, 22, 6, "frey50" );
+ unless ( $record->subfield( 100, "a" ) ) {
+ $record->insert_grouped_field(
+ MARC::Field->new( 100, "", "", "a" => $string ) );
+ }
+ }
+# warn "biblionumber : ".$biblionumber;
+ $sth =
+ $dbh->prepare(
+ "update biblioitems set marc=?,marcxml=? where biblionumber=?");
+ $sth->execute( $record->as_usmarc(), $record->as_xml_record(),
+ $biblionumber );
+# warn $record->as_xml_record();
+ $sth->finish;
+ zebraop($dbh,$biblionumber,"specialUpdate","biblioserver");
+ return $biblionumber;
+}
+
+=head2 MARCadditem
+
+$newbiblionumber = MARCadditem( $record, $biblionumber, $frameworkcode );
+
+=cut
+
+sub MARCadditem {
+
+# pass the MARC::Record to this function, and it will create the records in the marc tables
+ my ( $record, $biblionumber, $frameworkcode ) = @_;
+ my $newrec = &GetMarcBiblio($biblionumber);
+
+ # 2nd recreate it
+ my @fields = $record->fields();
+ foreach my $field (@fields) {
+ $newrec->append_fields($field);
+ }
+
+ # FIXME: should we be making sure the biblionumbers are the same?
+ my $newbiblionumber =
+ &MARCaddbiblio( $newrec, $biblionumber, $frameworkcode );
+ return $newbiblionumber;
+}
+
+=head2 GetMarcBiblio
+
+Returns MARC::Record of the biblionumber passed in parameter.
+
+=cut
+
+sub GetMarcBiblio {
+ my $biblionumber = shift;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare("select marcxml from biblioitems where biblionumber=? ");
+ $sth->execute($biblionumber);
+ my ($marcxml) = $sth->fetchrow;
+# warn "marcxml : $marcxml";
+ MARC::File::XML->default_record_format(C4::Context->preference('marcflavour'));
+ $marcxml =~ s/\x1e//g;
+ $marcxml =~ s/\x1f//g;
+ $marcxml =~ s/\x1d//g;
+ $marcxml =~ s/\x0f//g;
+ $marcxml =~ s/\x0c//g;
+ my $record = MARC::Record->new();
+ $record = MARC::Record::new_from_xml( $marcxml, "utf8",C4::Context->preference('marcflavour')) if $marcxml;
+ return $record;
+}
+
+=head2 GetXmlBiblio
+
+my $marcxml = GetXmlBiblio($biblionumber);
+
+Returns biblioitems.marcxml of the biblionumber passed in parameter.
+
+=cut
+
+sub GetXmlBiblio {
+ my ( $biblionumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare("select marcxml from biblioitems where biblionumber=? ");
+ $sth->execute($biblionumber);
+ my ($marcxml) = $sth->fetchrow;
+ return $marcxml;
+}
+
+=head2 GetAuthorisedValueDesc
+
+my $subfieldvalue =get_authorised_value_desc(
+ $tag, $subf[$i][0],$subf[$i][1], '', $taglib);
+
+=cut
+
+sub GetAuthorisedValueDesc {
+ my ( $tag, $subfield, $value, $framework, $tagslib ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ #---- branch
+ if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "branches" ) {
+ return C4::Branch::GetBranchName($value);
+ }
+
+ #---- itemtypes
+ if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "itemtypes" ) {
+ return getitemtypeinfo($value);
+ }
+
+ #---- "true" authorized value
+ my $category = $tagslib->{$tag}->{$subfield}->{'authorised_value'};
+
+ if ( $category ne "" ) {
+ my $sth =
+ $dbh->prepare(
+ "select lib from authorised_values where category = ? and authorised_value = ?"
+ );
+ $sth->execute( $category, $value );
+ my $data = $sth->fetchrow_hashref;
+ return $data->{'lib'};
+ }
+ else {
+ return $value; # if nothing is found return the original value
+ }
+}
+
+=head2 MARCgetitem
+
+Returns MARC::Record of the item passed in parameter.
+
+=cut
+
+sub MARCgetitem {
+ my ( $biblionumber, $itemnumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $newrecord = MARC::Record->new();
+ my $marcflavour = C4::Context->preference('marcflavour');
+
+ my $marcxml = GetXmlBiblio($biblionumber);
+ my $record = MARC::Record->new();
+# warn "marcxml :$marcxml";
+ $record = MARC::Record::new_from_xml( $marcxml, "utf8", $marcflavour );
+# warn "record :".$record->as_formatted;
+ # now, find where the itemnumber is stored & extract only the item
+ my ( $itemnumberfield, $itemnumbersubfield ) =
+ MARCfind_marc_from_kohafield( $dbh, 'items.itemnumber', '' );
+ my @fields = $record->field($itemnumberfield);
+ foreach my $field (@fields) {
+ if ( $field->subfield($itemnumbersubfield) eq $itemnumber ) {
+ $newrecord->insert_fields_ordered($field);
+ }
+ }
+ return $newrecord;
+}
+
+=head2 GetMarcNotes
+
+$marcnotesarray = GetMarcNotes( $record, $marcflavour );
+
+get a single record in piggyback mode from Zebra and return it in the requested record syntax
+
+default record syntax is XML
+
+=cut
+
+sub GetMarcNotes {
+ my ( $record, $marcflavour ) = @_;
+ my $scope;
+ if ( $marcflavour eq "MARC21" ) {
+ $scope = '5..';
+ }
+ else { # assume unimarc if not marc21
+ $scope = '3..';
+ }
+ my @marcnotes;
+ my $note = "";
+ my $tag = "";
+ my $marcnote;
+ foreach my $field ( $record->field($scope) ) {
+ my $value = $field->as_string();
+ if ( $note ne "" ) {
+ $marcnote = { marcnote => $note, };
+ push @marcnotes, $marcnote;
+ $note = $value;
+ }
+ if ( $note ne $value ) {
+ $note = $note . " " . $value;
+ }
+ }
+
+ if ( $note ) {
+ $marcnote = { marcnote => $note };
+ push @marcnotes, $marcnote; #load last tag into array
+ }
+ return \@marcnotes;
+} # end GetMarcNotes
+
+=head2 GetMarcSubjects
+
+$marcsubjcts = GetMarcSubjects($record,$marcflavour);
+
+=cut
+
+sub GetMarcSubjects {
+ my ( $record, $marcflavour ) = @_;
+ my ( $mintag, $maxtag );
+ if ( $marcflavour eq "MARC21" ) {
+ $mintag = "600";
+ $maxtag = "699";
+ }
+ else { # assume unimarc if not marc21
+ $mintag = "600";
+ $maxtag = "611";
+ }
+
+ my @marcsubjcts;
+
+ foreach my $field ( $record->fields ) {
+ next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
+ my @subfields = $field->subfields();
+ my $link;
+ my $label = "su:";
+ my $flag = 0;
+ for my $subject_subfield ( @subfields ) {
+ my $code = $subject_subfield->[0];
+ $label .= $subject_subfield->[1] . " and su-to:" unless ( $code == 9 );
+ if ( $code == 9 ) {
+ $link = "Koha-Auth-Number:".$subject_subfield->[1];
+ $flag = 1;
+ }
+ elsif ( ! $flag ) {
+ $link = $label;
+ $link =~ s/ and\ssu-to:$//;
+ }
+ }
+ $label =~ s/su/ /g;
+ $label =~ s/://g;
+ $label =~ s/-to//g;
+ $label =~ s/and//g;
+ push @marcsubjcts,
+ {
+ label => $label,
+ link => $link
+ }
+ }
+ return \@marcsubjcts;
+} #end GetMarcSubjects
+
+=head2 GetMarcAuthors
+
+authors = GetMarcAuthors($record,$marcflavour);
+
+=cut
+
+sub GetMarcAuthors {
+ my ( $record, $marcflavour ) = @_;
+ my ( $mintag, $maxtag );
+ if ( $marcflavour eq "MARC21" ) {
+ $mintag = "100";
+ $maxtag = "111";
+ }
+ else { # assume unimarc if not marc21
+ $mintag = "701";
+ $maxtag = "712";
+ }
+
+ my @marcauthors;
+
+ foreach my $field ( $record->fields ) {
+ next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
+ my %hash;
+ my @subfields = $field->subfields();
+ my $count_auth = 0;
+ my $and ;
+ for my $authors_subfield (@subfields) {
+ if ($count_auth ne '0'){
+ $and = " and au:";
+ }
+ $count_auth++;
+ my $subfieldcode = $authors_subfield->[0];
+ my $value = $authors_subfield->[1];
+ $hash{'tag'} = $field->tag;
+ $hash{value} .= $value . " " if ($subfieldcode != 9) ;
+ $hash{link} .= $value if ($subfieldcode eq 9);
+ }
+ push @marcauthors, \%hash;
+ }
+ return \@marcauthors;
+}
+
+=head2 GetMarcSeries
+
+$marcseriessarray = GetMarcSeries($record,$marcflavour);
+
+=cut
+
+sub GetMarcSeries {
+ my ($record, $marcflavour) = @_;
+ my ($mintag, $maxtag);
+ if ($marcflavour eq "MARC21") {
+ $mintag = "440";
+ $maxtag = "490";
+ } else { # assume unimarc if not marc21
+ $mintag = "600";
+ $maxtag = "619";
+ }
+
+ my @marcseries;
+ my $subjct = "";
+ my $subfield = "";
+ my $marcsubjct;
+
+ foreach my $field ($record->field('440'), $record->field('490')) {
+ my @subfields_loop;
+ #my $value = $field->subfield('a');
+ #$marcsubjct = {MARCSUBJCT => $value,};
+ my @subfields = $field->subfields();
+ #warn "subfields:".join " ", @$subfields;
+ my $counter = 0;
+ my @link_loop;
+ for my $series_subfield (@subfields) {
+ my $volume_number;
+ undef $volume_number;
+ # see if this is an instance of a volume
+ if ($series_subfield->[0] eq 'v') {
+ $volume_number=1;
+ }
+
+ my $code = $series_subfield->[0];
+ my $value = $series_subfield->[1];
+ my $linkvalue = $value;
+ $linkvalue =~ s/(\(|\))//g;
+ my $operator = " and " unless $counter==0;
+ push @link_loop, {link => $linkvalue, operator => $operator };
+ my $separator = C4::Context->preference("authoritysep") unless $counter==0;
+ if ($volume_number) {
+ push @subfields_loop, {volumenum => $value};
+ }
+ else {
+ push @subfields_loop, {code => $code, value => $value, link_loop => \@link_loop, separator => $separator, volumenum => $volume_number};
+ }
+ $counter++;
+ }
+ push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
+ #$marcsubjct = {MARCSUBJCT => $field->as_string(),};
+ #push @marcsubjcts, $marcsubjct;
+ #$subjct = $value;
+
+ }
+ my $marcseriessarray=\@marcseries;
+ return $marcseriessarray;
+} #end getMARCseriess
+
+=head2 MARCmodbiblio
+
+MARCmodbibio($dbh,$biblionumber,$record,$frameworkcode,1);
+
+Modify a biblio record with the option to save items data
+
+=cut
+
+sub MARCmodbiblio {
+ my ( $dbh, $biblionumber, $record, $frameworkcode, $keep_items ) = @_;
+
+ # delete original record but save the items
+ my $newrec = &MARCdelbiblio( $biblionumber, $keep_items );
+
+ # recreate it and add the new fields
+ my @fields = $record->fields();
+ foreach my $field (@fields) {
+
+ # this requires a more recent version of MARC::Record
+ # but ensures the fields are in order
+ $newrec->insert_fields_ordered($field);
+ }
+
+ # give back our old leader
+ $newrec->leader( $record->leader() );
+
+ # add the record back with the items info preserved
+ &MARCaddbiblio( $newrec, $biblionumber, $frameworkcode );
+}
+
+=head2 MARCdelbiblio
+
+&MARCdelbiblio( $biblionumber, $keep_items )
+
+if the keep_item is set to 1, then all items are preserved.
+This flag is set when the delbiblio is called by modbiblio
+due to a too complex structure of MARC (repeatable fields and subfields),
+the best solution for a modif is to delete / recreate the record.
+
+1st of all, copy the MARC::Record to deletedbiblio table => if a true deletion, MARC data will be kept.
+if deletion called before MARCmodbiblio => won't do anything, as the oldbiblionumber doesn't
+exist in deletedbiblio table
+
+=cut
+
+sub MARCdelbiblio {
+ my ( $biblionumber, $keep_items ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my $record = GetMarcBiblio($biblionumber);
+ my $oldbiblionumber = $biblionumber;
+ my $copy2deleted =
+ $dbh->prepare("update deletedbiblio set marc=? where biblionumber=?");
+ $copy2deleted->execute( $record->as_usmarc(), $oldbiblionumber );
+ my @fields = $record->fields();
+
+ # now, delete in MARC tables.
+ if ( $keep_items eq 1 ) {
+ #search item field code
+ my $sth =
+ $dbh->prepare(
+"select tagfield from marc_subfield_structure where kohafield like 'items.%'"
+ );
+ $sth->execute;
+ my $itemtag = $sth->fetchrow_hashref->{tagfield};
+
+ foreach my $field (@fields) {
+
+ if ( $field->tag() ne $itemtag ) {
+ $record->delete_field($field);
+ } #if
+ } #foreach
+ }
+ else {
+ foreach my $field (@fields) {
+
+ $record->delete_field($field);
+ } #foreach
+ }
+ return $record;
+}
+
+=head2 MARCdelitem
+
+MARCdelitem( $biblionumber, $itemnumber )
+
+delete the item field from the MARC record for the itemnumber specified
+
+=cut
+
+sub MARCdelitem {
+ my ( $biblionumber, $itemnumber ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # get the MARC record
+ my $record = GetMarcBiblio($biblionumber);
+
+ # backup the record
+ my $copy2deleted =
+ $dbh->prepare("UPDATE deleteditems SET marc=? WHERE itemnumber=?");
+ $copy2deleted->execute( $record->as_usmarc(), $itemnumber );
+
+ #search item field code
+ my $sth =
+ $dbh->prepare(
+"SELECT tagfield,tagsubfield FROM marc_subfield_structure WHERE kohafield LIKE 'items.itemnumber'"
+ );
+ $sth->execute;
+ my ( $itemtag, $itemsubfield ) = $sth->fetchrow;
+ my @fields = $record->field($itemtag);
+ # delete the item specified
+ foreach my $field (@fields) {
+ if ( $field->subfield($itemsubfield) eq $itemnumber ) {
+ $record->delete_field($field);
+ }
+ }
+ return $record;
+}
+
+=head2 MARCmoditemonefield
+
+&MARCmoditemonefield( $biblionumber, $itemnumber, $itemfield, $newvalue )
+
+=cut
+
+sub MARCmoditemonefield {
+ my ( $biblionumber, $itemnumber, $itemfield, $newvalue ) = @_;
+ my $dbh = C4::Context->dbh;
+ if ( !defined $newvalue ) {
+ $newvalue = "";
+ }
+
+ my $record = MARCgetitem( $biblionumber, $itemnumber );
+
+ my $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield from marc_subfield_structure where kohafield=?"
+ );
+ my $tagfield;
+ my $tagsubfield;
+ $sth->execute($itemfield);
+ if ( ( $tagfield, $tagsubfield ) = $sth->fetchrow ) {
+ my $tag = $record->field($tagfield);
+ if ($tag) {
+ my $tagsubs = $record->field($tagfield)->subfield($tagsubfield);
+ $tag->update( $tagsubfield => $newvalue );
+ $record->delete_field($tag);
+ $record->insert_fields_ordered($tag);
+ &MARCmoditem( $record, $biblionumber, $itemnumber, 0 );
+ }
+ }
+}
+
+=head2 MARCmoditem
+
+&MARCmoditem( $record, $biblionumber, $itemnumber, $frameworkcode, $delete )
+
+=cut
+
+sub MARCmoditem {
+ my ( $record, $biblionumber, $itemnumber, $frameworkcode, $delete ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # delete this item from MARC
+ my $newrec = &MARCdelitem( $biblionumber, $itemnumber );
+
+ # 2nd recreate it
+ my @fields = $record->fields();
+ ###NEU specific add cataloguers cardnumber as well
+ my $cardtag = C4::Context->preference('itemcataloguersubfield');
+
+ foreach my $field (@fields) {
+ if ($cardtag) {
+ my $me = C4::Context->userenv;
+ my $cataloguer = $me->{'cardnumber'} if ($me);
+ $field->update( $cardtag => $cataloguer ) if ($me);
+ }
+ $newrec->append_fields($field);
+ }
+ &MARCaddbiblio( $newrec, $biblionumber, $frameworkcode );
+}
+
+=head2 MARCfind_frameworkcode
+
+$frameworkcode = MARCfind_frameworkcode( $biblionumber )
+
+=cut
+
+sub MARCfind_frameworkcode {
+ my ( $biblionumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare("select frameworkcode from biblio where biblionumber=?");
+ $sth->execute($biblionumber);
+ my ($frameworkcode) = $sth->fetchrow;
+ return $frameworkcode;
+}
+
+=head2 Koha2Marc
+
+$record = Koha2Marc( $hash )
+
+This function builds partial MARC::Record from a hash
+
+Hash entries can be from biblio or biblioitems.
+
+This function is called in acquisition module, to create a basic catalogue entry from user entry
+
+=cut
+
+sub Koha2Marc {
+
+ my ( $hash ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
+ );
+ my $record = MARC::Record->new();
+ foreach (keys %{$hash}) {
+ &MARCkoha2marcOnefield( $sth, $record, $_,
+ $hash->{$_}, '' );
+ }
+ return $record;
+}
+
+=head2 MARCkoha2marcBiblio
+
+$record = MARCkoha2marcBiblio( $biblionumber, $biblioitemnumber )
+
+this function builds partial MARC::Record from the old koha-DB fields
+
+=cut
+
+sub MARCkoha2marcBiblio {
+
+ my ( $biblionumber, $biblioitemnumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
+ );
+ my $record = MARC::Record->new();
+
+ #--- if biblionumber, then retrieve old-style koha data
+ if ( $biblionumber > 0 ) {
+ my $sth2 = $dbh->prepare(
+"select biblionumber,author,title,unititle,notes,abstract,serial,seriestitle,copyrightdate,timestamp
+ from biblio where biblionumber=?"
+ );
+ $sth2->execute($biblionumber);
+ my $row = $sth2->fetchrow_hashref;
+ my $code;
+ foreach $code ( keys %$row ) {
+ if ( $row->{$code} ) {
+ &MARCkoha2marcOnefield( $sth, $record, "biblio." . $code,
+ $row->{$code}, '' );
+ }
+ }
+ }
+
+ #--- if biblioitem, then retrieve old-style koha data
+ if ( $biblioitemnumber > 0 ) {
+ my $sth2 = $dbh->prepare(
+ " SELECT biblioitemnumber,biblionumber,volume,number,classification,
+ itemtype,url,isbn,issn,dewey,subclass,publicationyear,publishercode,
+ volumedate,volumeddesc,timestamp,illus,pages,notes AS bnotes,size,place
+ FROM biblioitems
+ WHERE biblioitemnumber=?
+ "
+ );
+ $sth2->execute($biblioitemnumber);
+ my $row = $sth2->fetchrow_hashref;
+ my $code;
+ foreach $code ( keys %$row ) {
+ if ( $row->{$code} ) {
+ &MARCkoha2marcOnefield( $sth, $record, "biblioitems." . $code,
+ $row->{$code}, '' );
+ }
+ }
+ }
+ return $record;
+}
+
+=head2 MARCkoha2marcItem
+
+$record = MARCkoha2marcItem( $dbh, $biblionumber, $itemnumber );
+
+=cut
+
+sub MARCkoha2marcItem {
+
+ # this function builds partial MARC::Record from the old koha-DB fields
+ my ( $dbh, $biblionumber, $itemnumber ) = @_;
+
+ # my $dbh=&C4Connect;
+ my $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
+ );
+ my $record = MARC::Record->new();
+
+ #--- if item, then retrieve old-style koha data
+ if ( $itemnumber > 0 ) {
+
+ # print STDERR "prepare $biblionumber,$itemnumber\n";
+ my $sth2 = $dbh->prepare(
+"SELECT itemnumber,biblionumber,multivolumepart,biblioitemnumber,barcode,dateaccessioned,
+ booksellerid,homebranch,price,replacementprice,replacementpricedate,datelastborrowed,
+ datelastseen,multivolume,stack,notforloan,itemlost,wthdrawn,itemcallnumber,issues,renewals,
+ reserves,restricted,binding,itemnotes,holdingbranch,timestamp,onloan,Cutterextra
+ FROM items
+ WHERE itemnumber=?"
+ );
+ $sth2->execute($itemnumber);
+ my $row = $sth2->fetchrow_hashref;
+ my $code;
+ foreach $code ( keys %$row ) {
+ if ( $row->{$code} ) {
+ &MARCkoha2marcOnefield( $sth, $record, "items." . $code,
+ $row->{$code}, '' );
+ }
+ }
+ }
+ return $record;
+}
+
+=head2 MARCkoha2marcOnefield
+
+$record = MARCkoha2marcOnefield( $sth, $record, $kohafieldname, $value, $frameworkcode );
+
+=cut
+
+sub MARCkoha2marcOnefield {
+ my ( $sth, $record, $kohafieldname, $value, $frameworkcode ) = @_;
+ $frameworkcode='' unless $frameworkcode;
+ my $tagfield;
+ my $tagsubfield;
+
+ if ( !defined $sth ) {
+ my $dbh = C4::Context->dbh;
+ $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
+ );
+ }
+ $sth->execute( $frameworkcode, $kohafieldname );
+ if ( ( $tagfield, $tagsubfield ) = $sth->fetchrow ) {
+ my $tag = $record->field($tagfield);
+ if ($tag) {
+ $tag->update( $tagsubfield => $value );
+ $record->delete_field($tag);
+ $record->insert_fields_ordered($tag);
+ }
+ else {
+ $record->add_fields( $tagfield, " ", " ", $tagsubfield => $value );
+ }
+ }
+ return $record;
+}
+
+=head2 MARChtml2xml
+
+$xml = MARChtml2xml( $tags, $subfields, $values, $indicator, $ind_tag )
+
+=cut
+
+sub MARChtml2xml {
+ my ( $tags, $subfields, $values, $indicator, $ind_tag ) = @_;
+ my $xml = MARC::File::XML::header('UTF-8');
+ if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
+ MARC::File::XML->default_record_format('UNIMARC');
+ use POSIX qw(strftime);
+ my $string = strftime( "%Y%m%d", localtime(time) );
+ $string = sprintf( "%-*s", 35, $string );
+ substr( $string, 22, 6, "frey50" );
+ $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
+ $xml .= "<subfield code=\"a\">$string</subfield>\n";
+ $xml .= "</datafield>\n";
+ }
+ my $prevvalue;
+ my $prevtag = -1;
+ my $first = 1;
+ my $j = -1;
+ for ( my $i = 0 ; $i <= @$tags ; $i++ ) {
+ @$values[$i] =~ s/&/&/g;
+ @$values[$i] =~ s/</</g;
+ @$values[$i] =~ s/>/>/g;
+ @$values[$i] =~ s/"/"/g;
+ @$values[$i] =~ s/'/'/g;
+ if ( !utf8::is_utf8( @$values[$i] ) ) {
+ utf8::decode( @$values[$i] );
+ }
+ if ( ( @$tags[$i] ne $prevtag ) ) {
+ $j++ unless ( @$tags[$i] eq "" );
+ if ( !$first ) {
+ $xml .= "</datafield>\n";
+ if ( ( @$tags[$i] && @$tags[$i] > 10 )
+ && ( @$values[$i] ne "" ) )
+ {
+ my $ind1 = substr( @$indicator[$j], 0, 1 );
+ my $ind2;
+ if ( @$indicator[$j] ) {
+ $ind2 = substr( @$indicator[$j], 1, 1 );
+ }
+ else {
+ warn "Indicator in @$tags[$i] is empty";
+ $ind2 = " ";
+ }
+ $xml .=
+"<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $xml .=
+"<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ $first = 0;
+ }
+ else {
+ $first = 1;
+ }
+ }
+ else {
+ if ( @$values[$i] ne "" ) {
+
+ # leader
+ if ( @$tags[$i] eq "000" ) {
+ $xml .= "<leader>@$values[$i]</leader>\n";
+ $first = 1;
+
+ # rest of the fixed fields
+ }
+ elsif ( @$tags[$i] < 10 ) {
+ $xml .=
+"<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
+ $first = 1;
+ }
+ else {
+ my $ind1 = substr( @$indicator[$j], 0, 1 );
+ my $ind2 = substr( @$indicator[$j], 1, 1 );
+ $xml .=
+"<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $xml .=
+"<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ $first = 0;
+ }
+ }
+ }
+ }
+ else { # @$tags[$i] eq $prevtag
+ if ( @$values[$i] eq "" ) {
+ }
+ else {
+ if ($first) {
+ my $ind1 = substr( @$indicator[$j], 0, 1 );
+ my $ind2 = substr( @$indicator[$j], 1, 1 );
+ $xml .=
+"<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $first = 0;
+ }
+ $xml .=
+"<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ }
+ }
+ $prevtag = @$tags[$i];
+ }
+ $xml .= MARC::File::XML::footer();
+
+ return $xml;
+}
+
+=head2 MARChtml2marc
+
+$record = MARChtml2marc( $dbh, $rtags, $rsubfields, $rvalues, %indicators )
+
+=cut
+
+sub MARChtml2marc {
+ my ( $dbh, $rtags, $rsubfields, $rvalues, %indicators ) = @_;
+ my $prevtag = -1;
+ my $record = MARC::Record->new();
+
+ # my %subfieldlist=();
+ my $prevvalue; # if tag <10
+ my $field; # if tag >=10
+ for ( my $i = 0 ; $i < @$rtags ; $i++ ) {
+ next unless @$rvalues[$i];
+
+ # rebuild MARC::Record
+ # warn "0=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ";
+ if ( @$rtags[$i] ne $prevtag ) {
+ if ( $prevtag < 10 ) {
+ if ($prevvalue) {
+
+ if ( $prevtag ne '000' ) {
+ $record->insert_fields_ordered(
+ ( sprintf "%03s", $prevtag ), $prevvalue );
+ }
+ else {
+
+ $record->leader($prevvalue);
+
+ }
+ }
+ }
+ else {
+ if ($field) {
+ $record->insert_fields_ordered($field);
+ }
+ }
+ $indicators{ @$rtags[$i] } .= ' ';
+ if ( @$rtags[$i] < 10 ) {
+ $prevvalue = @$rvalues[$i];
+ undef $field;
+ }
+ else {
+ undef $prevvalue;
+ $field = MARC::Field->new(
+ ( sprintf "%03s", @$rtags[$i] ),
+ substr( $indicators{ @$rtags[$i] }, 0, 1 ),
+ substr( $indicators{ @$rtags[$i] }, 1, 1 ),
+ @$rsubfields[$i] => @$rvalues[$i]
+ );
+ }
+ $prevtag = @$rtags[$i];
+ }
+ else {
+ if ( @$rtags[$i] < 10 ) {
+ $prevvalue = @$rvalues[$i];
+ }
+ else {
+ if ( length( @$rvalues[$i] ) > 0 ) {
+ $field->add_subfields( @$rsubfields[$i] => @$rvalues[$i] );
+ }
+ }
+ $prevtag = @$rtags[$i];
+ }
+ }
+
+ # the last has not been included inside the loop... do it now !
+ $record->insert_fields_ordered($field) if $field;
+
+ # warn "HTML2MARC=".$record->as_formatted;
+ $record->encoding('UTF-8');
+
+ # $record->MARC::File::USMARC::update_leader();
+ return $record;
+}
+
+=head2 MARCmarc2koha
+
+$result = MARCmarc2koha( $dbh, $record, $frameworkcode )
+
+=cut
+
+sub MARCmarc2koha {
+ my ( $dbh, $record, $frameworkcode ) = @_;
+ my $sth =
+ $dbh->prepare(
+"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
+ );
+ my $result;
+ my $sth2 = $dbh->prepare("SHOW COLUMNS from biblio");
+ $sth2->execute;
+ my $field;
+ while ( ($field) = $sth2->fetchrow ) {
+ $result =
+ &MARCmarc2kohaOneField( "biblio", $field, $record, $result,
+ $frameworkcode );
+ }
+ $sth2 = $dbh->prepare("SHOW COLUMNS from biblioitems");
+ $sth2->execute;
+ while ( ($field) = $sth2->fetchrow ) {
+ if ( $field eq 'notes' ) { $field = 'bnotes'; }
+ $result =
+ &MARCmarc2kohaOneField( "biblioitems", $field, $record, $result,
+ $frameworkcode );
+ }
+ $sth2 = $dbh->prepare("SHOW COLUMNS from items");
+ $sth2->execute;
+ while ( ($field) = $sth2->fetchrow ) {
+ $result =
+ &MARCmarc2kohaOneField( "items", $field, $record, $result,
+ $frameworkcode );
+ }
+
+ #
+ # modify copyrightdate to keep only the 1st year found
+ my $temp = $result->{'copyrightdate'};
+ $temp =~ m/c(\d\d\d\d)/; # search cYYYY first
+ if ( $1 > 0 ) {
+ $result->{'copyrightdate'} = $1;
+ }
+ else { # if no cYYYY, get the 1st date.
+ $temp =~ m/(\d\d\d\d)/;
+ $result->{'copyrightdate'} = $1;
+ }
+
+ # modify publicationyear to keep only the 1st year found
+ $temp = $result->{'publicationyear'};
+ $temp =~ m/c(\d\d\d\d)/; # search cYYYY first
+ if ( $1 > 0 ) {
+ $result->{'publicationyear'} = $1;
+ }
+ else { # if no cYYYY, get the 1st date.
+ $temp =~ m/(\d\d\d\d)/;
+ $result->{'publicationyear'} = $1;
+ }
+ return $result;
+}
+
+=head2 MARCmarc2kohaOneField
+
+$result = MARCmarc2kohaOneField( $kohatable, $kohafield, $record, $result, $frameworkcode )
+
+=cut
+
+sub MARCmarc2kohaOneField {
+
+# FIXME ? if a field has a repeatable subfield that is used in old-db, only the 1st will be retrieved...
+ my ( $kohatable, $kohafield, $record, $result, $frameworkcode ) = @_;
+
+ my $res = "";
+ my ( $tagfield, $subfield ) =
+ MARCfind_marc_from_kohafield( "", $kohatable . "." . $kohafield,
+ $frameworkcode );
+ foreach my $field ( $record->field($tagfield) ) {
+ if ( $field->tag() < 10 ) {
+ if ( $result->{$kohafield} ) {
+ $result->{$kohafield} .= " | " . $field->data();
+ }
+ else {
+ $result->{$kohafield} = $field->data();
+ }
+ }
+ else {
+ if ( $field->subfields ) {
+ my @subfields = $field->subfields();
+ foreach my $subfieldcount ( 0 .. $#subfields ) {
+ if ( $subfields[$subfieldcount][0] eq $subfield ) {
+ if ( $result->{$kohafield} ) {
+ $result->{$kohafield} .=
+ " | " . $subfields[$subfieldcount][1];
+ }
+ else {
+ $result->{$kohafield} =
+ $subfields[$subfieldcount][1];
+ }
+ }
+ }
+ }
+ }
+ }
+ return $result;
+}
+
+=head2 MARCitemchange
+
+&MARCitemchange( $record, $itemfield, $newvalue )
+
+=cut
+
+sub MARCitemchange {
+ my ( $record, $itemfield, $newvalue ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my ( $tagfield, $tagsubfield ) =
+ MARCfind_marc_from_kohafield( $dbh, $itemfield, "" );
+ if ( ($tagfield) && ($tagsubfield) ) {
+ my $tag = $record->field($tagfield);
+ if ($tag) {
+ $tag->update( $tagsubfield => $newvalue );
+ $record->delete_field($tag);
+ $record->insert_fields_ordered($tag);
+ }
+ }
+}
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _koha_add_biblio
+
+_koha_add_biblio($dbh,$biblioitem);
+
+Internal function to add a biblio ($biblio is a hash with the values)
+
+=cut
+
+sub _koha_add_biblio {
+ my ( $dbh, $biblio, $frameworkcode ) = @_;
+ my $sth = $dbh->prepare("Select max(biblionumber) from biblio");
+ $sth->execute;
+ my $data = $sth->fetchrow_arrayref;
+ my $biblionumber = $$data[0] + 1;
+ my $series = 0;
+
+ if ( $biblio->{'seriestitle'} ) { $series = 1 }
+ $sth->finish;
+ $sth = $dbh->prepare(
+ "INSERT INTO biblio
+ SET biblionumber = ?, title = ?, author = ?, copyrightdate = ?, serial = ?, seriestitle = ?, notes = ?, abstract = ?, unititle = ?, frameworkcode = ? "
+ );
+ $sth->execute(
+ $biblionumber, $biblio->{'title'},
+ $biblio->{'author'}, $biblio->{'copyrightdate'},
+ $biblio->{'serial'}, $biblio->{'seriestitle'},
+ $biblio->{'notes'}, $biblio->{'abstract'},
+ $biblio->{'unititle'}, $frameworkcode
+ );
+
+ $sth->finish;
+ return ($biblionumber);
+}
+
+=head2 _find_value
+
+ ($indicators, $value) = _find_value($tag, $subfield, $record,$encoding);
+
+Find the given $subfield in the given $tag in the given
+MARC::Record $record. If the subfield is found, returns
+the (indicators, value) pair; otherwise, (undef, undef) is
+returned.
+
+PROPOSITION :
+Such a function is used in addbiblio AND additem and serial-edit and maybe could be used in Authorities.
+I suggest we export it from this module.
+
+=cut
+
+sub _find_value {
+ my ( $tagfield, $insubfield, $record, $encoding ) = @_;
+ my @result;
+ my $indicator;
+ if ( $tagfield < 10 ) {
+ if ( $record->field($tagfield) ) {
+ push @result, $record->field($tagfield)->data();
+ }
+ else {
+ push @result, "";
+ }
+ }
+ else {
+ foreach my $field ( $record->field($tagfield) ) {
+ my @subfields = $field->subfields();
+ foreach my $subfield (@subfields) {
+ if ( @$subfield[0] eq $insubfield ) {
+ push @result, @$subfield[1];
+ $indicator = $field->indicator(1) . $field->indicator(2);
+ }
+ }
+ }
+ }
+ return ( $indicator, @result );
+}
+
+=head2 _koha_modify_biblio
+
+Internal function for updating the biblio table
+
+=cut
+
+sub _koha_modify_biblio {
+ my ( $dbh, $biblio ) = @_;
+
+# FIXME: this code could be made more portable by not hard-coding the values that are supposed to be in biblio table
+ my $sth =
+ $dbh->prepare(
+"Update biblio set title = ?, author = ?, abstract = ?, copyrightdate = ?, seriestitle = ?, serial = ?, unititle = ?, notes = ? where biblionumber = ?"
+ );
+ $sth->execute(
+ $biblio->{'title'}, $biblio->{'author'},
+ $biblio->{'abstract'}, $biblio->{'copyrightdate'},
+ $biblio->{'seriestitle'}, $biblio->{'serial'},
+ $biblio->{'unititle'}, $biblio->{'notes'},
+ $biblio->{'biblionumber'}
+ );
+ $sth->finish;
+ return ( $biblio->{'biblionumber'} );
+}
+
+=head2 _koha_modify_biblioitem
+
+_koha_modify_biblioitem( $dbh, $biblioitem );
+
+=cut
+
+sub _koha_modify_biblioitem {
+ my ( $dbh, $biblioitem ) = @_;
+ my $query;
+##Recalculate LC in case it changed --TG
+
+ $biblioitem->{'itemtype'} = $dbh->quote( $biblioitem->{'itemtype'} );
+ $biblioitem->{'url'} = $dbh->quote( $biblioitem->{'url'} );
+ $biblioitem->{'isbn'} = $dbh->quote( $biblioitem->{'isbn'} );
+ $biblioitem->{'issn'} = $dbh->quote( $biblioitem->{'issn'} );
+ $biblioitem->{'publishercode'} =
+ $dbh->quote( $biblioitem->{'publishercode'} );
+ $biblioitem->{'publicationyear'} =
+ $dbh->quote( $biblioitem->{'publicationyear'} );
+ $biblioitem->{'classification'} =
+ $dbh->quote( $biblioitem->{'classification'} );
+ $biblioitem->{'dewey'} = $dbh->quote( $biblioitem->{'dewey'} );
+ $biblioitem->{'subclass'} = $dbh->quote( $biblioitem->{'subclass'} );
+ $biblioitem->{'illus'} = $dbh->quote( $biblioitem->{'illus'} );
+ $biblioitem->{'pages'} = $dbh->quote( $biblioitem->{'pages'} );
+ $biblioitem->{'volumeddesc'} = $dbh->quote( $biblioitem->{'volumeddesc'} );
+ $biblioitem->{'bnotes'} = $dbh->quote( $biblioitem->{'bnotes'} );
+ $biblioitem->{'size'} = $dbh->quote( $biblioitem->{'size'} );
+ $biblioitem->{'place'} = $dbh->quote( $biblioitem->{'place'} );
+ $biblioitem->{'ccode'} = $dbh->quote( $biblioitem->{'ccode'} );
+ $biblioitem->{'biblionumber'} =
+ $dbh->quote( $biblioitem->{'biblionumber'} );
+
+ $query = "Update biblioitems set
+ itemtype = $biblioitem->{'itemtype'},
+ url = $biblioitem->{'url'},
+ isbn = $biblioitem->{'isbn'},
+ issn = $biblioitem->{'issn'},
+ publishercode = $biblioitem->{'publishercode'},
+ publicationyear = $biblioitem->{'publicationyear'},
+ classification = $biblioitem->{'classification'},
+ dewey = $biblioitem->{'dewey'},
+ subclass = $biblioitem->{'subclass'},
+ illus = $biblioitem->{'illus'},
+ pages = $biblioitem->{'pages'},
+ volumeddesc = $biblioitem->{'volumeddesc'},
+ notes = $biblioitem->{'bnotes'},
+ size = $biblioitem->{'size'},
+ place = $biblioitem->{'place'},
+ ccode = $biblioitem->{'ccode'}
+ where biblionumber = $biblioitem->{'biblionumber'}";
+
+ $dbh->do($query);
+ if ( $dbh->errstr ) {
+ warn "$query";
+ }
+}
+
+=head2 _koha_modify_note
+
+_koha_modify_note( $dbh, $bibitemnum, $note );
+
+=cut
+
+sub _koha_modify_note {
+ my ( $dbh, $bibitemnum, $note ) = @_;
+
+ # my $dbh=C4Connect;
+ my $query = "update biblioitems set notes='$note' where
+ biblioitemnumber='$bibitemnum'";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ $sth->finish;
+}
+
+=head2 _koha_add_biblioitem
+
+_koha_add_biblioitem( $dbh, $biblioitem );
+
+Internal function to add a biblioitem
+
+=cut
+
+sub _koha_add_biblioitem {
+ my ( $dbh, $biblioitem ) = @_;
+
+ # my $dbh = C4Connect;
+ my $sth = $dbh->prepare("SELECT max(biblioitemnumber) FROM biblioitems");
+ my $data;
+ my $bibitemnum;
+
+ $sth->execute;
+ $data = $sth->fetchrow_arrayref;
+ $bibitemnum = $$data[0] + 1;
+
+ $sth->finish;
+
+ $sth = $dbh->prepare(
+ "INSERT INTO biblioitems SET
+ biblioitemnumber = ?, biblionumber = ?,
+ volume = ?, number = ?,
+ classification = ?, itemtype = ?,
+ url = ?, isbn = ?,
+ issn = ?, dewey = ?,
+ subclass = ?, publicationyear = ?,
+ publishercode = ?, volumedate = ?,
+ volumeddesc = ?, illus = ?,
+ pages = ?, notes = ?,
+ size = ?, lccn = ?,
+ marc = ?, lcsort =?,
+ place = ?, ccode = ?
+ "
+ );
+ my ($lcsort) =
+ calculatelc( $biblioitem->{'classification'} )
+ . $biblioitem->{'subclass'};
+ $sth->execute(
+ $bibitemnum, $biblioitem->{'biblionumber'},
+ $biblioitem->{'volume'}, $biblioitem->{'number'},
+ $biblioitem->{'classification'}, $biblioitem->{'itemtype'},
+ $biblioitem->{'url'}, $biblioitem->{'isbn'},
+ $biblioitem->{'issn'}, $biblioitem->{'dewey'},
+ $biblioitem->{'subclass'}, $biblioitem->{'publicationyear'},
+ $biblioitem->{'publishercode'}, $biblioitem->{'volumedate'},
+ $biblioitem->{'volumeddesc'}, $biblioitem->{'illus'},
+ $biblioitem->{'pages'}, $biblioitem->{'bnotes'},
+ $biblioitem->{'size'}, $biblioitem->{'lccn'},
+ $biblioitem->{'marc'}, $biblioitem->{'place'},
+ $lcsort, $biblioitem->{'ccode'}
+ );
+ $sth->finish;
+ return ($bibitemnum);
+}
+
+=head2 _koha_new_items
+
+_koha_new_items( $dbh, $item, $barcode );
+
+=cut
+
+sub _koha_new_items {
+ my ( $dbh, $item, $barcode ) = @_;
+
+ # my $dbh = C4Connect;
+ my $sth = $dbh->prepare("Select max(itemnumber) from items");
+ my $data;
+ my $itemnumber;
+ my $error = "";
+
+ $sth->execute;
+ $data = $sth->fetchrow_hashref;
+ $itemnumber = $data->{'max(itemnumber)'} + 1;
+ $sth->finish;
+## Now calculate lccalnumber
+ my ($cutterextra) = itemcalculator(
+ $dbh,
+ $item->{'biblioitemnumber'},
+ $item->{'itemcallnumber'}
+ );
+
+# FIXME the "notforloan" field seems to be named "loan" in some places. workaround bugfix.
+ if ( $item->{'loan'} ) {
+ $item->{'notforloan'} = $item->{'loan'};
+ }
+
+ # if dateaccessioned is provided, use it. Otherwise, set to NOW()
+ if ( $item->{'dateaccessioned'} eq '' || !$item->{'dateaccessioned'} ) {
+
+ $sth = $dbh->prepare(
+ "Insert into items set
+ itemnumber = ?, biblionumber = ?,
+ multivolumepart = ?,
+ biblioitemnumber = ?, barcode = ?,
+ booksellerid = ?, dateaccessioned = NOW(),
+ homebranch = ?, holdingbranch = ?,
+ price = ?, replacementprice = ?,
+ replacementpricedate = NOW(), datelastseen = NOW(),
+ multivolume = ?, stack = ?,
+ itemlost = ?, wthdrawn = ?,
+ paidfor = ?, itemnotes = ?,
+ itemcallnumber =?, notforloan = ?,
+ location = ?, Cutterextra = ?
+ "
+ );
+ $sth->execute(
+ $itemnumber, $item->{'biblionumber'},
+ $item->{'multivolumepart'}, $item->{'biblioitemnumber'},
+ $barcode, $item->{'booksellerid'},
+ $item->{'homebranch'}, $item->{'holdingbranch'},
+ $item->{'price'}, $item->{'replacementprice'},
+ $item->{multivolume}, $item->{stack},
+ $item->{itemlost}, $item->{wthdrawn},
+ $item->{paidfor}, $item->{'itemnotes'},
+ $item->{'itemcallnumber'}, $item->{'notforloan'},
+ $item->{'location'}, $cutterextra
+ );
+ }
+ else {
+ $sth = $dbh->prepare(
+ "INSERT INTO items SET
+ itemnumber = ?, biblionumber = ?,
+ multivolumepart = ?,
+ biblioitemnumber = ?, barcode = ?,
+ booksellerid = ?, dateaccessioned = ?,
+ homebranch = ?, holdingbranch = ?,
+ price = ?, replacementprice = ?,
+ replacementpricedate = NOW(), datelastseen = NOW(),
+ multivolume = ?, stack = ?,
+ itemlost = ?, wthdrawn = ?,
+ paidfor = ?, itemnotes = ?,
+ itemcallnumber = ?, notforloan = ?,
+ location = ?,
+ Cutterextra = ?
+ "
+ );
+ $sth->execute(
+ $itemnumber, $item->{'biblionumber'},
+ $item->{'multivolumepart'}, $item->{'biblioitemnumber'},
+ $barcode, $item->{'booksellerid'},
+ $item->{'dateaccessioned'}, $item->{'homebranch'},
+ $item->{'holdingbranch'}, $item->{'price'},
+ $item->{'replacementprice'}, $item->{multivolume},
+ $item->{stack}, $item->{itemlost},
+ $item->{wthdrawn}, $item->{paidfor},
+ $item->{'itemnotes'}, $item->{'itemcallnumber'},
+ $item->{'notforloan'}, $item->{'location'},
+ $cutterextra
+ );
+ }
+ if ( defined $sth->errstr ) {
+ $error .= $sth->errstr;
+ }
+ return ( $itemnumber, $error );
+}
+
+=head2 _koha_modify_item
+
+_koha_modify_item( $dbh, $item, $op );
+
+=cut
+
+sub _koha_modify_item {
+ my ( $dbh, $item, $op ) = @_;
+ $item->{'itemnum'} = $item->{'itemnumber'} unless $item->{'itemnum'};
+
+ # if all we're doing is setting statuses, just update those and get out
+ if ( $op eq "setstatus" ) {
+ my $query =
+ "UPDATE items SET itemlost=?,wthdrawn=?,binding=? WHERE itemnumber=?";
+ my @bind = (
+ $item->{'itemlost'}, $item->{'wthdrawn'},
+ $item->{'binding'}, $item->{'itemnumber'}
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ $sth->finish;
+ return undef;
+ }
+## Now calculate lccalnumber
+ my ($cutterextra) =
+ itemcalculator( $dbh, $item->{'bibitemnum'}, $item->{'itemcallnumber'} );
+
+ my $query = "UPDATE items SET
+barcode=?,itemnotes=?,itemcallnumber=?,notforloan=?,location=?,multivolumepart=?,multivolume=?,stack=?,wthdrawn=?,holdingbranch=?,homebranch=?,cutterextra=?, onloan=?, binding=?";
+
+ my @bind = (
+ $item->{'barcode'}, $item->{'notes'},
+ $item->{'itemcallnumber'}, $item->{'notforloan'},
+ $item->{'location'}, $item->{multivolumepart},
+ $item->{multivolume}, $item->{stack},
+ $item->{wthdrawn}, $item->{holdingbranch},
+ $item->{homebranch}, $cutterextra,
+ $item->{onloan}, $item->{binding}
+ );
+ if ( $item->{'lost'} ne '' ) {
+ $query =
+"update items set biblioitemnumber=?,barcode=?,itemnotes=?,homebranch=?,
+ itemlost=?,wthdrawn=?,itemcallnumber=?,notforloan=?,
+ location=?,multivolumepart=?,multivolume=?,stack=?,wthdrawn=?,holdingbranch=?,cutterextra=?,onloan=?, binding=?";
+ @bind = (
+ $item->{'bibitemnum'}, $item->{'barcode'},
+ $item->{'notes'}, $item->{'homebranch'},
+ $item->{'lost'}, $item->{'wthdrawn'},
+ $item->{'itemcallnumber'}, $item->{'notforloan'},
+ $item->{'location'}, $item->{multivolumepart},
+ $item->{multivolume}, $item->{stack},
+ $item->{wthdrawn}, $item->{holdingbranch},
+ $cutterextra, $item->{onloan},
+ $item->{binding}
+ );
+ if ( $item->{homebranch} ) {
+ $query .= ",homebranch=?";
+ push @bind, $item->{homebranch};
+ }
+ if ( $item->{holdingbranch} ) {
+ $query .= ",holdingbranch=?";
+ push @bind, $item->{holdingbranch};
+ }
+ }
+ $query .= " where itemnumber=?";
+ push @bind, $item->{'itemnum'};
+ if ( $item->{'replacement'} ne '' ) {
+ $query =~ s/ where/,replacementprice='$item->{'replacement'}' where/;
+ }
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ $sth->finish;
+}
+
+=head2 _koha_delete_item
+
+_koha_delete_item( $dbh, $itemnum );
+
+Internal function to delete an item record from the koha tables
+
+=cut
+
+sub _koha_delete_item {
+ my ( $dbh, $itemnum ) = @_;
+
+ my $sth = $dbh->prepare("select * from items where itemnumber=?");
+ $sth->execute($itemnum);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ my $query = "Insert into deleteditems set ";
+ my @bind = ();
+ foreach my $temp ( keys %$data ) {
+ $query .= "$temp = ?,";
+ push( @bind, $data->{$temp} );
+ }
+ $query =~ s/\,$//;
+
+ # print $query;
+ $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ $sth->finish;
+ $sth = $dbh->prepare("Delete from items where itemnumber=?");
+ $sth->execute($itemnum);
+ $sth->finish;
+}
+
+=head2 _koha_delete_biblio
+
+$error = _koha_delete_biblio($dbh,$biblionumber);
+
+Internal sub for deleting from biblio table -- also saves to deletedbiblio
+
+C<$dbh> - the database handle
+C<$biblionumber> - the biblionumber of the biblio to be deleted
+
+=cut
+
+# FIXME: add error handling
+
+sub _koha_delete_biblio {
+ my ( $dbh, $biblionumber ) = @_;
+
+ # get all the data for this biblio
+ my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
+ $sth->execute($biblionumber);
+
+ if ( my $data = $sth->fetchrow_hashref ) {
+
+ # save the record in deletedbiblio
+ # find the fields to save
+ my $query = "INSERT INTO deletedbiblio SET ";
+ my @bind = ();
+ foreach my $temp ( keys %$data ) {
+ $query .= "$temp = ?,";
+ push( @bind, $data->{$temp} );
+ }
+
+ # replace the last , by ",?)"
+ $query =~ s/\,$//;
+ my $bkup_sth = $dbh->prepare($query);
+ $bkup_sth->execute(@bind);
+ $bkup_sth->finish;
+
+ # delete the biblio
+ my $del_sth = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
+ $del_sth->execute($biblionumber);
+ $del_sth->finish;
+ }
+ $sth->finish;
+ return undef;
+}
+
+=head2 _koha_delete_biblioitems
+
+$error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
+
+Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
+
+C<$dbh> - the database handle
+C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
+
+=cut
+
+# FIXME: add error handling
+
+sub _koha_delete_biblioitems {
+ my ( $dbh, $biblioitemnumber ) = @_;
+
+ # get all the data for this biblioitem
+ my $sth =
+ $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
+ $sth->execute($biblioitemnumber);
+
+ if ( my $data = $sth->fetchrow_hashref ) {
+
+ # save the record in deletedbiblioitems
+ # find the fields to save
+ my $query = "INSERT INTO deletedbiblioitems SET ";
+ my @bind = ();
+ foreach my $temp ( keys %$data ) {
+ $query .= "$temp = ?,";
+ push( @bind, $data->{$temp} );
+ }
+
+ # replace the last , by ",?)"
+ $query =~ s/\,$//;
+ my $bkup_sth = $dbh->prepare($query);
+ $bkup_sth->execute(@bind);
+ $bkup_sth->finish;
+
+ # delete the biblioitem
+ my $del_sth =
+ $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
+ $del_sth->execute($biblioitemnumber);
+ $del_sth->finish;
+ }
+ $sth->finish;
+ return undef;
+}
+
+=head2 _koha_delete_items
+
+$error = _koha_delete_items($dbh,$itemnumber);
+
+Internal sub for deleting from items table -- also saves to deleteditems
+
+C<$dbh> - the database handle
+C<$itemnumber> - the itemnumber of the item to be deleted
+
+=cut
+
+# FIXME: add error handling
+
+sub _koha_delete_items {
+ my ( $dbh, $itemnumber ) = @_;
+
+ # get all the data for this item
+ my $sth = $dbh->prepare("SELECT * FROM items WHERE itemnumber=?");
+ $sth->execute($itemnumber);
+
+ if ( my $data = $sth->fetchrow_hashref ) {
+
+ # save the record in deleteditems
+ # find the fields to save
+ my $query = "INSERT INTO deleteditems SET ";
+ my @bind = ();
+ foreach my $temp ( keys %$data ) {
+ $query .= "$temp = ?,";
+ push( @bind, $data->{$temp} );
+ }
+
+ # replace the last , by ",?)"
+ $query =~ s/\,$//;
+ my $bkup_sth = $dbh->prepare($query);
+ $bkup_sth->execute(@bind);
+ $bkup_sth->finish;
+
+ # delete the item
+ my $del_sth = $dbh->prepare("DELETE FROM items WHERE itemnumber=?");
+ $del_sth->execute($itemnumber);
+ $del_sth->finish;
+ }
+ $sth->finish;
+ return undef;
+}
+
+
+
+=head2 modbiblio
+
+ $biblionumber = &modbiblio($biblio);
+
+Update a biblio record.
+
+C<$biblio> is a reference-to-hash whose keys are the fields in the
+biblio table in the Koha database. All fields must be present, not
+just the ones you wish to change.
+
+C<&modbiblio> updates the record defined by
+C<$biblio-E<gt>{biblionumber}> with the values in C<$biblio>.
+
+C<&modbiblio> returns C<$biblio-E<gt>{biblionumber}> whether it was
+successful or not.
+
+=cut
+
+sub modbiblio {
+ my ($biblio) = @_;
+ my $dbh = C4::Context->dbh;
+ my $biblionumber = _koha_modify_biblio( $dbh, $biblio );
+ my $record = MARCkoha2marcBiblio( $biblionumber, $biblionumber );
+ MARCmodbiblio( $dbh, $biblionumber, $record, "", 0 );
+ return ($biblionumber);
+} # sub modbiblio
+
+=head2 modbibitem
+
+&modbibitem($biblioitem)
+
+=cut
+
+sub modbibitem {
+ my ($biblioitem) = @_;
+ my $dbh = C4::Context->dbh;
+ &_koha_modify_biblio( $dbh, $biblioitem );
+} # sub modbibitem
+
+
+=head2 newitems
+
+$errors = &newitems( $item, @barcodes );
+
+=cut
+
+sub newitems {
+ my ( $item, @barcodes ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $errors;
+ my $itemnumber;
+ my $error;
+ foreach my $barcode (@barcodes) {
+ ( $itemnumber, $error ) = &_koha_new_items( $dbh, $item, uc($barcode) );
+ $errors .= $error;
+ my $MARCitem =
+ &MARCkoha2marcItem( $dbh, $item->{biblionumber}, $itemnumber );
+ &MARCadditem( $MARCitem, $item->{biblionumber} );
+ }
+ return ($errors);
+}
+
+=head2 moditem
+
+$errors = &moditem( $item, $op );
+
+=cut
+
+sub moditem {
+ my ( $item, $op ) = @_;
+ my $dbh = C4::Context->dbh;
+ &_koha_modify_item( $dbh, $item, $op );
+
+ # if we're just setting statuses, just update items table
+ # it's faster and zebra and marc will be synched anyway by the cron job
+ unless ( $op eq "setstatus" ) {
+ my $MARCitem = &MARCkoha2marcItem( $dbh, $item->{'biblionumber'},
+ $item->{'itemnum'} );
+ &MARCmoditem( $MARCitem, $item->{biblionumber}, $item->{itemnum},
+ MARCfind_frameworkcode( $item->{biblionumber} ), 0 );
+ }
+}
+
+=head2 checkitems
+
+$errors = &checkitems( $count, @barcodes );
+
+=cut
+
+sub checkitems {
+ my ( $count, @barcodes ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $error;
+ my $sth = $dbh->prepare("Select * from items where barcode=?");
+ for ( my $i = 0 ; $i < $count ; $i++ ) {
+ $barcodes[$i] = uc $barcodes[$i];
+ $sth->execute( $barcodes[$i] );
+ if ( my $data = $sth->fetchrow_hashref ) {
+ $error .= " Duplicate Barcode: $barcodes[$i]";
+ }
+ }
+ $sth->finish;
+ return ($error);
+}
+
+=head1 OTHER FUNCTIONS
+
+=head2 char_decode
+
+my $string = char_decode( $string, $encoding );
+
+converts ISO 5426 coded string to UTF-8
+sloppy code : should be improved in next issue
+
+=cut
+
+sub char_decode {
+ my ( $string, $encoding ) = @_;
+ $_ = $string;
+
+ $encoding = C4::Context->preference("marcflavour") unless $encoding;
+ if ( $encoding eq "UNIMARC" ) {
+
+ # s/\xe1/Æ/gm;
+ s/\xe2/Äž/gm;
+ s/\xe9/Ø/gm;
+ s/\xec/ÅŸ/gm;
+ s/\xf1/æ/gm;
+ s/\xf3/ÄŸ/gm;
+ s/\xf9/ø/gm;
+ s/\xfb/ß/gm;
+ s/\xc1\x61/Ã /gm;
+ s/\xc1\x65/è/gm;
+ s/\xc1\x69/ì/gm;
+ s/\xc1\x6f/ò/gm;
+ s/\xc1\x75/ù/gm;
+ s/\xc1\x41/À/gm;
+ s/\xc1\x45/È/gm;
+ s/\xc1\x49/Ì/gm;
+ s/\xc1\x4f/Ã’/gm;
+ s/\xc1\x55/Ù/gm;
+ s/\xc2\x41/Ã/gm;
+ s/\xc2\x45/É/gm;
+ s/\xc2\x49/Ã/gm;
+ s/\xc2\x4f/Ó/gm;
+ s/\xc2\x55/Ú/gm;
+ s/\xc2\x59/Ä°/gm;
+ s/\xc2\x61/á/gm;
+ s/\xc2\x65/é/gm;
+ s/\xc2\x69/Ã/gm;
+ s/\xc2\x6f/ó/gm;
+ s/\xc2\x75/ú/gm;
+ s/\xc2\x79/ı/gm;
+ s/\xc3\x41/Â/gm;
+ s/\xc3\x45/Ê/gm;
+ s/\xc3\x49/ÃŽ/gm;
+ s/\xc3\x4f/Ô/gm;
+ s/\xc3\x55/Û/gm;
+ s/\xc3\x61/â/gm;
+ s/\xc3\x65/ê/gm;
+ s/\xc3\x69/î/gm;
+ s/\xc3\x6f/ô/gm;
+ s/\xc3\x75/û/gm;
+ s/\xc4\x41/Ã/gm;
+ s/\xc4\x4e/Ñ/gm;
+ s/\xc4\x4f/Õ/gm;
+ s/\xc4\x61/ã/gm;
+ s/\xc4\x6e/ñ/gm;
+ s/\xc4\x6f/õ/gm;
+ s/\xc8\x41/Ä/gm;
+ s/\xc8\x45/Ë/gm;
+ s/\xc8\x49/Ã/gm;
+ s/\xc8\x61/ä/gm;
+ s/\xc8\x65/ë/gm;
+ s/\xc8\x69/ï/gm;
+ s/\xc8\x6F/ö/gm;
+ s/\xc8\x75/ü/gm;
+ s/\xc8\x76/ÿ/gm;
+ s/\xc9\x41/Ä/gm;
+ s/\xc9\x45/Ë/gm;
+ s/\xc9\x49/Ã/gm;
+ s/\xc9\x4f/Ö/gm;
+ s/\xc9\x55/Ü/gm;
+ s/\xc9\x61/ä/gm;
+ s/\xc9\x6f/ö/gm;
+ s/\xc9\x75/ü/gm;
+ s/\xca\x41/Ã…/gm;
+ s/\xca\x61/Ã¥/gm;
+ s/\xd0\x43/Ç/gm;
+ s/\xd0\x63/ç/gm;
+
+ # this handles non-sorting blocks (if implementation requires this)
+ $string = nsb_clean($_);
+ }
+ elsif ( $encoding eq "USMARC" || $encoding eq "MARC21" ) {
+ ##MARC-8 to UTF-8
+
+ s/\xe1\x61/Ã /gm;
+ s/\xe1\x65/è/gm;
+ s/\xe1\x69/ì/gm;
+ s/\xe1\x6f/ò/gm;
+ s/\xe1\x75/ù/gm;
+ s/\xe1\x41/À/gm;
+ s/\xe1\x45/È/gm;
+ s/\xe1\x49/Ì/gm;
+ s/\xe1\x4f/Ã’/gm;
+ s/\xe1\x55/Ù/gm;
+ s/\xe2\x41/Ã/gm;
+ s/\xe2\x45/É/gm;
+ s/\xe2\x49/Ã/gm;
+ s/\xe2\x4f/Ó/gm;
+ s/\xe2\x55/Ú/gm;
+ s/\xe2\x59/Ä°/gm;
+ s/\xe2\x61/á/gm;
+ s/\xe2\x65/é/gm;
+ s/\xe2\x69/Ã/gm;
+ s/\xe2\x6f/ó/gm;
+ s/\xe2\x75/ú/gm;
+ s/\xe2\x79/ı/gm;
+ s/\xe3\x41/Â/gm;
+ s/\xe3\x45/Ê/gm;
+ s/\xe3\x49/ÃŽ/gm;
+ s/\xe3\x4f/Ô/gm;
+ s/\xe3\x55/Û/gm;
+ s/\xe3\x61/â/gm;
+ s/\xe3\x65/ê/gm;
+ s/\xe3\x69/î/gm;
+ s/\xe3\x6f/ô/gm;
+ s/\xe3\x75/û/gm;
+ s/\xe4\x41/Ã/gm;
+ s/\xe4\x4e/Ñ/gm;
+ s/\xe4\x4f/Õ/gm;
+ s/\xe4\x61/ã/gm;
+ s/\xe4\x6e/ñ/gm;
+ s/\xe4\x6f/õ/gm;
+ s/\xe6\x41/Ä‚/gm;
+ s/\xe6\x45/Ä”/gm;
+ s/\xe6\x65/Ä•/gm;
+ s/\xe6\x61/ă/gm;
+ s/\xe8\x45/Ë/gm;
+ s/\xe8\x49/Ã/gm;
+ s/\xe8\x65/ë/gm;
+ s/\xe8\x69/ï/gm;
+ s/\xe8\x76/ÿ/gm;
+ s/\xe9\x41/A/gm;
+ s/\xe9\x4f/O/gm;
+ s/\xe9\x55/U/gm;
+ s/\xe9\x61/a/gm;
+ s/\xe9\x6f/o/gm;
+ s/\xe9\x75/u/gm;
+ s/\xea\x41/A/gm;
+ s/\xea\x61/a/gm;
+
+ #Additional Turkish characters
+ s/\x1b//gm;
+ s/\x1e//gm;
+ s/(\xf0)s/\xc5\x9f/gm;
+ s/(\xf0)S/\xc5\x9e/gm;
+ s/(\xf0)c/ç/gm;
+ s/(\xf0)C/Ç/gm;
+ s/\xe7\x49/\\xc4\xb0/gm;
+ s/(\xe6)G/\xc4\x9e/gm;
+ s/(\xe6)g/ÄŸ\xc4\x9f/gm;
+ s/\xB8/ı/gm;
+ s/\xB9/£/gm;
+ s/(\xe8|\xc8)o/ö/gm;
+ s/(\xe8|\xc8)O/Ö/gm;
+ s/(\xe8|\xc8)u/ü/gm;
+ s/(\xe8|\xc8)U/Ü/gm;
+ s/\xc2\xb8/\xc4\xb1/gm;
+ s/¸/\xc4\xb1/gm;
+
+ # this handles non-sorting blocks (if implementation requires this)
+ $string = nsb_clean($_);
+ }
+ return ($string);
+}
+
+=head2 PrepareItemrecordDisplay
+
+PrepareItemrecordDisplay($itemrecord,$bibnum,$itemumber);
+
+Returns a hash with all the fields for Display a given item data in a template
+
+=cut
+
+sub PrepareItemrecordDisplay {
+
+ my ( $bibnum, $itemnum ) = @_;
+
+ my $dbh = C4::Context->dbh;
+ my $frameworkcode = &MARCfind_frameworkcode( $bibnum );
+ my ( $itemtagfield, $itemtagsubfield ) =
+ &MARCfind_marc_from_kohafield( $dbh, "items.itemnumber", $frameworkcode );
+ my $tagslib = &MARCgettagslib( $dbh, 1, $frameworkcode );
+ my $itemrecord = MARCgetitem( $bibnum, $itemnum) if ($itemnum);
+ my @loop_data;
+ my $authorised_values_sth =
+ $dbh->prepare(
+"select authorised_value,lib from authorised_values where category=? order by lib"
+ );
+ foreach my $tag ( sort keys %{$tagslib} ) {
+ my $previous_tag = '';
+ if ( $tag ne '' ) {
+ # loop through each subfield
+ my $cntsubf;
+ foreach my $subfield ( sort keys %{ $tagslib->{$tag} } ) {
+ next if ( subfield_is_koha_internal_p($subfield) );
+ next if ( $tagslib->{$tag}->{$subfield}->{'tab'} ne "10" );
+ my %subfield_data;
+ $subfield_data{tag} = $tag;
+ $subfield_data{subfield} = $subfield;
+ $subfield_data{countsubfield} = $cntsubf++;
+ $subfield_data{kohafield} =
+ $tagslib->{$tag}->{$subfield}->{'kohafield'};
+
+ # $subfield_data{marc_lib}=$tagslib->{$tag}->{$subfield}->{lib};
+ $subfield_data{marc_lib} =
+ "<span id=\"error\" title=\""
+ . $tagslib->{$tag}->{$subfield}->{lib} . "\">"
+ . substr( $tagslib->{$tag}->{$subfield}->{lib}, 0, 12 )
+ . "</span>";
+ $subfield_data{mandatory} =
+ $tagslib->{$tag}->{$subfield}->{mandatory};
+ $subfield_data{repeatable} =
+ $tagslib->{$tag}->{$subfield}->{repeatable};
+ $subfield_data{hidden} = "display:none"
+ if $tagslib->{$tag}->{$subfield}->{hidden};
+ my ( $x, $value );
+ ( $x, $value ) = _find_value( $tag, $subfield, $itemrecord )
+ if ($itemrecord);
+ $value =~ s/"/"/g;
+
+ # search for itemcallnumber if applicable
+ if ( $tagslib->{$tag}->{$subfield}->{kohafield} eq
+ 'items.itemcallnumber'
+ && C4::Context->preference('itemcallnumber') )
+ {
+ my $CNtag =
+ substr( C4::Context->preference('itemcallnumber'), 0, 3 );
+ my $CNsubfield =
+ substr( C4::Context->preference('itemcallnumber'), 3, 1 );
+ my $temp = $itemrecord->field($CNtag) if ($itemrecord);
+ if ($temp) {
+ $value = $temp->subfield($CNsubfield);
+ }
+ }
+ if ( $tagslib->{$tag}->{$subfield}->{authorised_value} ) {
+ my @authorised_values;
+ my %authorised_lib;
+
+ # builds list, depending on authorised value...
+ #---- branch
+ if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq
+ "branches" )
+ {
+ if ( ( C4::Context->preference("IndependantBranches") )
+ && ( C4::Context->userenv->{flags} != 1 ) )
+ {
+ my $sth =
+ $dbh->prepare(
+"select branchcode,branchname from branches where branchcode = ? order by branchname"
+ );
+ $sth->execute( C4::Context->userenv->{branch} );
+ push @authorised_values, ""
+ unless (
+ $tagslib->{$tag}->{$subfield}->{mandatory} );
+ while ( my ( $branchcode, $branchname ) =
+ $sth->fetchrow_array )
+ {
+ push @authorised_values, $branchcode;
+ $authorised_lib{$branchcode} = $branchname;
+ }
+ }
+ else {
+ my $sth =
+ $dbh->prepare(
+"select branchcode,branchname from branches order by branchname"
+ );
+ $sth->execute;
+ push @authorised_values, ""
+ unless (
+ $tagslib->{$tag}->{$subfield}->{mandatory} );
+ while ( my ( $branchcode, $branchname ) =
+ $sth->fetchrow_array )
+ {
+ push @authorised_values, $branchcode;
+ $authorised_lib{$branchcode} = $branchname;
+ }
+ }
+
+ #----- itemtypes
+ }
+ elsif ( $tagslib->{$tag}->{$subfield}->{authorised_value} eq
+ "itemtypes" )
+ {
+ my $sth =
+ $dbh->prepare(
+"select itemtype,description from itemtypes order by description"
+ );
+ $sth->execute;
+ push @authorised_values, ""
+ unless ( $tagslib->{$tag}->{$subfield}->{mandatory} );
+ while ( my ( $itemtype, $description ) =
+ $sth->fetchrow_array )
+ {
+ push @authorised_values, $itemtype;
+ $authorised_lib{$itemtype} = $description;
+ }
+
+ #---- "true" authorised value
+ }
+ else {
+ $authorised_values_sth->execute(
+ $tagslib->{$tag}->{$subfield}->{authorised_value} );
+ push @authorised_values, ""
+ unless ( $tagslib->{$tag}->{$subfield}->{mandatory} );
+ while ( my ( $value, $lib ) =
+ $authorised_values_sth->fetchrow_array )
+ {
+ push @authorised_values, $value;
+ $authorised_lib{$value} = $lib;
+ }
+ }
+ $subfield_data{marc_value} = CGI::scrolling_list(
+ -name => 'field_value',
+ -values => \@authorised_values,
+ -default => "$value",
+ -labels => \%authorised_lib,
+ -size => 1,
+ -tabindex => '',
+ -multiple => 0,
+ );
+ }
+ elsif ( $tagslib->{$tag}->{$subfield}->{thesaurus_category} ) {
+ $subfield_data{marc_value} =
+"<input type=\"text\" name=\"field_value\" size=47 maxlength=255> <a href=\"javascript:Dopop('cataloguing/thesaurus_popup.pl?category=$tagslib->{$tag}->{$subfield}->{thesaurus_category}&index=',)\">...</a>";
+
+#"
+# COMMENTED OUT because No $i is provided with this API.
+# And thus, no value_builder can be activated.
+# BUT could be thought over.
+# } elsif ($tagslib->{$tag}->{$subfield}->{'value_builder'}) {
+# my $plugin="value_builder/".$tagslib->{$tag}->{$subfield}->{'value_builder'};
+# require $plugin;
+# my $extended_param = plugin_parameters($dbh,$itemrecord,$tagslib,$i,0);
+# my ($function_name,$javascript) = plugin_javascript($dbh,$record,$tagslib,$i,0);
+# $subfield_data{marc_value}="<input type=\"text\" value=\"$value\" name=\"field_value\" size=47 maxlength=255 DISABLE READONLY OnFocus=\"javascript:Focus$function_name()\" OnBlur=\"javascript:Blur$function_name()\"> <a href=\"javascript:Clic$function_name()\">...</a> $javascript";
+ }
+ else {
+ $subfield_data{marc_value} =
+"<input type=\"text\" name=\"field_value\" value=\"$value\" size=50 maxlength=255>";
+ }
+ push( @loop_data, \%subfield_data );
+ }
+ }
+ }
+ my $itemnumber = $itemrecord->subfield( $itemtagfield, $itemtagsubfield )
+ if ( $itemrecord && $itemrecord->field($itemtagfield) );
+ return {
+ 'itemtagfield' => $itemtagfield,
+ 'itemtagsubfield' => $itemtagsubfield,
+ 'itemnumber' => $itemnumber,
+ 'iteminformation' => \@loop_data
+ };
+}
+
+=head2 nsb_clean
+
+my $string = nsb_clean( $string, $encoding );
+
+=cut
+
+sub nsb_clean {
+ my $NSB = '\x88'; # NSB : begin Non Sorting Block
+ my $NSE = '\x89'; # NSE : Non Sorting Block end
+ # handles non sorting blocks
+ my ($string) = @_;
+ $_ = $string;
+ s/$NSB/(/gm;
+ s/[ ]{0,1}$NSE/) /gm;
+ $string = $_;
+ return ($string);
+}
+
+=head2 zebraopfiles
+
+&zebraopfiles( $dbh, $biblionumber, $record, $folder, $server );
+
+=cut
+
+sub zebraopfiles {
+
+ my ( $dbh, $biblionumber, $record, $folder, $server ) = @_;
+
+ my $op;
+ my $zebradir =
+ C4::Context->zebraconfig($server)->{directory} . "/" . $folder . "/";
+ unless ( opendir( DIR, "$zebradir" ) ) {
+ warn "$zebradir not found";
+ return;
+ }
+ closedir DIR;
+ my $filename = $zebradir . $biblionumber;
+
+ if ($record) {
+ open( OUTPUT, ">", $filename . ".xml" );
+ print OUTPUT $record;
+ close OUTPUT;
+ }
+}
+
+=head2 zebraop
+
+zebraop( $dbh, $biblionumber, $op, $server );
+
+=cut
+
+sub zebraop {
+###Accepts a $server variable thus we can use it for biblios authorities or other zebra dbs
+ my ( $dbh, $biblionumber, $op, $server ) = @_;
+
+ #warn "SERVER:".$server;
+#
+# true zebraop commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
+# at the same time
+# replaced by a zebraqueue table, that is filled with zebraop to run.
+# the table is emptied by misc/cronjobs/zebraqueue_start.pl script
+
+my $sth=$dbh->prepare("insert into zebraqueue (biblio_auth_number ,server,operation) values(?,?,?)");
+$sth->execute($biblionumber,$server,$op);
+$sth->finish;
+
+#
+# my @Zconnbiblio;
+# my $tried = 0;
+# my $recon = 0;
+# my $reconnect = 0;
+# my $record;
+# my $shadow;
+#
+# reconnect:
+# $Zconnbiblio[0] = C4::Context->Zconn( $server, 0, 1 );
+#
+# if ( $server eq "biblioserver" ) {
+#
+# # it's unclear to me whether this should be in xml or MARC format
+# # but it is clear it should be nabbed from zebra rather than from
+# # the koha tables
+# $record = GetMarcBiblio($biblionumber);
+# $record = $record->as_xml_record() if $record;
+# # warn "RECORD $biblionumber => ".$record;
+# $shadow="biblioservershadow";
+#
+# # warn "RECORD $biblionumber => ".$record;
+# $shadow = "biblioservershadow";
+#
+# }
+# elsif ( $server eq "authorityserver" ) {
+# $record = C4::AuthoritiesMarc::XMLgetauthority( $dbh, $biblionumber );
+# $shadow = "authorityservershadow";
+# } ## Add other servers as necessary
+#
+# my $Zpackage = $Zconnbiblio[0]->package();
+# $Zpackage->option( action => $op );
+# $Zpackage->option( record => $record );
+#
+# retry:
+# $Zpackage->send("update");
+# my $i;
+# my $event;
+#
+# while ( ( $i = ZOOM::event( \@Zconnbiblio ) ) != 0 ) {
+# $event = $Zconnbiblio[0]->last_event();
+# last if $event == ZOOM::Event::ZEND;
+# }
+#
+# my ( $error, $errmsg, $addinfo, $diagset ) = $Zconnbiblio[0]->error_x();
+# if ( $error == 10000 && $reconnect == 0 )
+# { ## This is serious ZEBRA server is not available -reconnect
+# warn "problem with zebra server connection";
+# $reconnect = 1;
+# my $res = system('sc start "Z39.50 Server" >c:/zebraserver/error.log');
+#
+# #warn "Trying to restart ZEBRA Server";
+# #goto "reconnect";
+# }
+# elsif ( $error == 10007 && $tried < 2 )
+# { ## timeout --another 30 looonng seconds for this update
+# $tried = $tried + 1;
+# warn "warn: timeout, trying again";
+# goto "retry";
+# }
+# elsif ( $error == 10004 && $recon == 0 ) { ##Lost connection -reconnect
+# $recon = 1;
+# warn "error: reconnecting to zebra";
+# goto "reconnect";
+#
+# # as a last resort, we save the data to the filesystem to be indexed in batch
+# }
+# elsif ($error) {
+# warn
+# "Error-$server $op $biblionumber /errcode:, $error, /MSG:,$errmsg,$addinfo \n";
+# $Zpackage->destroy();
+# $Zconnbiblio[0]->destroy();
+# zebraopfiles( $dbh, $biblionumber, $record, $op, $server );
+# return;
+# }
+# if ( C4::Context->$shadow ) {
+# $Zpackage->send('commit');
+# while ( ( $i = ZOOM::event( \@Zconnbiblio ) ) != 0 ) {
+#
+# #waiting zebra to finish;
+# }
+# }
+# $Zpackage->destroy();
+}
+
+=head2 calculatelc
+
+$lc = calculatelc($classification);
+
+=cut
+
+sub calculatelc {
+ my ($classification) = @_;
+ $classification =~ s/^\s+|\s+$//g;
+ my $i = 0;
+ my $lc2;
+ my $lc1;
+
+ for ( $i = 0 ; $i < length($classification) ; $i++ ) {
+ my $c = ( substr( $classification, $i, 1 ) );
+ if ( $c ge '0' && $c le '9' ) {
+
+ $lc2 = substr( $classification, $i );
+ last;
+ }
+ else {
+ $lc1 .= substr( $classification, $i, 1 );
+
+ }
+ } #while
+
+ my $other = length($lc1);
+ if ( !$lc1 ) {
+ $other = 0;
+ }
+
+ my $extras;
+ if ( $other < 4 ) {
+ for ( 1 .. ( 4 - $other ) ) {
+ $extras .= "0";
+ }
+ }
+ $lc1 .= $extras;
+ $lc2 =~ s/^ //g;
+
+ $lc2 =~ s/ //g;
+ $extras = "";
+ ##Find the decimal part of $lc2
+ my $pos = index( $lc2, "." );
+ if ( $pos < 0 ) { $pos = length($lc2); }
+ if ( $pos >= 0 && $pos < 5 ) {
+ ##Pad lc2 with zeros to create a 5digit decimal needed in marc record to sort as numeric
+
+ for ( 1 .. ( 5 - $pos ) ) {
+ $extras .= "0";
+ }
+ }
+ $lc2 = $extras . $lc2;
+ return ( $lc1 . $lc2 );
+}
+
+=head2 itemcalculator
+
+$cutterextra = itemcalculator( $dbh, $biblioitem, $callnumber );
+
+=cut
+
+sub itemcalculator {
+ my ( $dbh, $biblioitem, $callnumber ) = @_;
+ my $sth =
+ $dbh->prepare(
+"select classification, subclass from biblioitems where biblioitemnumber=?"
+ );
+
+ $sth->execute($biblioitem);
+ my ( $classification, $subclass ) = $sth->fetchrow;
+ my $all = $classification . " " . $subclass;
+ my $total = length($all);
+ my $cutterextra = substr( $callnumber, $total - 1 );
+
+ return $cutterextra;
+}
END { } # module clean-up code here (global destructor)
-=back
+1;
+
+__END__
=head1 AUTHOR
Koha Developement team <info at koha.org>
+Paul POULAIN paul.poulain at free.fr
+Joshua Ferraro jmf at liblime.com
+
+=cut
+
+# $Id: Biblio.pm,v 1.188 2007/03/09 14:31:47 tipaul Exp $
+# $Log: Biblio.pm,v $
+# Revision 1.188 2007/03/09 14:31:47 tipaul
+# rel_3_0 moved to HEAD
+#
+# Revision 1.178.2.59 2007/02/28 10:01:13 toins
+# reporting bug fix from 2.2.7.1 to rel_3_0
+# LOG was :
+# BUGFIX/improvement : limiting MARCsubject to 610 as 676 is dewey, and is somewhere else
+#
+# Revision 1.178.2.58 2007/02/05 16:50:01 toins
+# fix a mod_perl bug:
+# There was a global var modified into an internal function in {MARC|ISBD}detail.pl.
+# Moving this function in Biblio.pm
+#
+# Revision 1.178.2.57 2007/01/25 09:37:58 tipaul
+# removing warn
+#
+# Revision 1.178.2.56 2007/01/24 13:50:26 tipaul
+# Acquisition fix
+# removing newbiblio & newbiblioitems subs.
+# adding Koha2Marc
+#
+# IMHO, all biblio handling is better handled if they are done in a single place, the subs with MARC::Record as parameters.
+# newbiblio & newbiblioitems where koha 1.x subs, that are called when MARC=OFF (which is not working anymore in koha 3.0, unless someone reintroduce it), and in acquisition module.
+# The Koha2Marc sub moves a hash (with biblio/biblioitems subfield as keys) into a MARC::Record, that can be used to call NewBiblio, the standard biblio manager sub.
+#
+# Revision 1.178.2.55 2007/01/17 18:07:17 alaurin
+# bugfixing for zebraqueue_start and biblio.pm :
+#
+# - Zebraqueue_start : restoring function of deletion in zebraqueue DB list
+#
+# -biblio.pm : changing method of default_record_format, now we have :
+# MARC::File::XML->default_record_format(C4::Context->preference('marcflavour'));
+#
+# with this line the encoding in zebra seems to be ok (in unimarc and marc21)
+#
+# Revision 1.178.2.54 2007/01/16 15:00:03 tipaul
+# donc try to delete the biblio in koha, just fill zebraqueue table !
+#
+# Revision 1.178.2.53 2007/01/16 10:24:11 tipaul
+# BUGFIXING :
+# when modifying or deleting an item, the biblio frameworkcode was emptied.
+#
+# Revision 1.178.2.52 2007/01/15 17:20:55 toins
+# *** empty log message ***
+#
+# Revision 1.178.2.51 2007/01/15 15:16:44 hdl
+# Uncommenting zebraop.
+#
+# Revision 1.178.2.50 2007/01/15 14:59:09 hdl
+# Adding creation of an unexpected serial any time.
+# +
+# USING Date::Calc and not Date::Manip.
+# WARNING : There are still some Bugs in next issue date management. (Date::Calc donot wrap easily next year calculation.)
+#
+# Revision 1.178.2.49 2007/01/12 10:12:30 toins
+# writing $record->as_formatted in the log when Modifying an item.
+#
+# Revision 1.178.2.48 2007/01/11 16:33:04 toins
+# write $record->as_formatted into the log.
+#
+# Revision 1.178.2.47 2007/01/10 16:46:27 toins
+# Theses modules need to use C4::Log.
+#
+# Revision 1.178.2.46 2007/01/10 16:31:15 toins
+# new systems preferences :
+# - CataloguingLog (log the update/creation/deletion of a notice if set to 1)
+# - BorrowersLog ( idem for borrowers )
+# - IssueLog (log all issue if set to 1)
+# - ReturnLog (log all return if set to 1)
+# - SusbcriptionLog (log all creation/deletion/update of a subcription)
+#
+# All of theses are in a new tab called 'LOGFeatures' in systempreferences.pl
+#
+# Revision 1.178.2.45 2007/01/09 10:31:09 toins
+# sync with dev_week. ( new function : GetMarcSeries )
+#
+# Revision 1.178.2.44 2007/01/04 17:41:32 tipaul
+# 2 major bugfixes :
+# - deletion of an item deleted the whole biblio because of a wrong API
+# - create an item was bugguy for default framework
+#
+# Revision 1.178.2.43 2006/12/22 15:09:53 toins
+# removing C4::Database;
+#
+# Revision 1.178.2.42 2006/12/20 16:51:00 tipaul
+# ZEBRA update :
+# - adding a new table : when a biblio is added/modified/ deleted, an entry is entered in this table
+# - the zebraqueue_start.pl script read it & does the stuff.
+#
+# code coming from head (tumer). it can be run every minut instead of once every day for dev_week code.
+#
+# I just have commented the previous code (=real time update) in Biblio.pm, we will be able to reactivate it once indexdata fixes zebra update bug !
+#
+# Revision 1.178.2.41 2006/12/20 08:54:44 toins
+# GetXmlBiblio wasn't exported.
+#
+# Revision 1.178.2.40 2006/12/19 16:45:56 alaurin
+# bugfixing, for zebra and authorities
+#
+# Revision 1.178.2.39 2006/12/08 17:55:44 toins
+# GetMarcAuthors now get authors for all subfields
+#
+# Revision 1.178.2.38 2006/12/07 15:42:14 toins
+# synching opac & intranet.
+# fix some broken link & bugs.
+# removing warn compilation.
+#
+# Revision 1.178.2.37 2006/12/07 11:09:39 tipaul
+# MAJOR FIX :
+# the ->destroy() line destroys the zebra connection. When we are running koha as cgi, it's not a problem, as the script dies after each request.
+# BUT for bulkmarcimport & mod_perl, the zebra conn must be persistant.
+#
+# Revision 1.178.2.36 2006/12/06 16:54:21 alaurin
+# restore function zebraop for delete biblios :
+#
+# 1) restore C4::Circulation::Circ2::itemissues, (was missing)
+# 2) restore zebraop value : delete_record
+#
+# Revision 1.178.2.35 2006/12/06 10:02:12 alaurin
+# bugfixing for delete a biblio :
+#
+# restore itemissue fonction .... :
+#
+# other is pointed, zebra error 224... for biblio is not deleted in zebra ..
+# ....
+#
+# Revision 1.178.2.34 2006/12/06 09:14:25 toins
+# Correct the link to the MARC subjects.
+#
+# Revision 1.178.2.33 2006/12/05 11:35:29 toins
+# Biblio.pm cleaned.
+# additionalauthors, bibliosubject, bibliosubtitle tables are now unused.
+# Some functions renamed according to the coding guidelines.
+#
+# Revision 1.178.2.32 2006/12/04 17:39:57 alaurin
+# bugfix :
+#
+# restore zebraop for update zebra
+#
+# Revision 1.178.2.31 2006/12/01 17:00:19 tipaul
+# additem needs $frameworkcode
+#
+# Revision 1.178.2.30 2006/11/30 18:23:51 toins
+# theses scripts don't need to use C4::Search.
+#
+# Revision 1.178.2.29 2006/11/30 17:17:01 toins
+# following functions moved from Search.p to Biblio.pm :
+# - bibdata
+# - itemsissues
+# - addauthor
+# - getMARCNotes
+# - getMARCsubjects
+#
+# Revision 1.178.2.28 2006/11/28 15:15:03 toins
+# sync with dev_week.
+# (deleteditems table wasn't getting populaated because the execute was commented out. This puts it back
+# -- some table changes are needed as well, I'll commit those separately.)
+#
+# Revision 1.178.2.27 2006/11/20 16:52:05 alaurin
+# minor bugfixing :
+#
+# correcting in _koha_modify_biblioitem : restore the biblionumber line .
+#
+# now the sql update of biblioitems is ok ....
+#
+# Revision 1.178.2.26 2006/11/17 14:57:21 tipaul
+# code cleaning : moving bornum, borrnum, bornumber to a correct "borrowernumber"
+#
+# Revision 1.178.2.25 2006/11/17 13:18:58 tipaul
+# code cleaning : removing use of "bib", and replacing with "biblionumber"
+#
+# WARNING : I tried to do carefully, but there are probably some mistakes.
+# So if you encounter a problem you didn't have before, look for this change !!!
+# anyway, I urge everybody to use only "biblionumber", instead of "bib", "bi", "biblio" or anything else. will be easier to maintain !!!
+#
+# Revision 1.178.2.24 2006/11/17 11:18:47 tipaul
+# * removing useless subs
+# * moving bibid to biblionumber where needed
+#
+# Revision 1.178.2.23 2006/11/17 09:39:04 btoumi
+# bug fix double declaration of variable in same function
+#
+# Revision 1.178.2.22 2006/11/15 15:15:50 hdl
+# Final First Version for New Facility for subscription management.
+#
+# Now
+# use serials-collection.pl for history display
+# and serials-edit.pl for serial edition
+# subscription add and detail adds a new branch information to help IndependantBranches Library to manage different subscriptions for a serial
+#
+# This is aimed at replacing serials-receive and statecollection.
+#
+# Revision 1.178.2.21 2006/11/15 14:49:38 tipaul
+# in some cases, there are invalid utf8 chars in XML (at least in SANOP). this commit remove them on the fly.
+# Not sure it's a good idea to keep them in biblio.pm, let me know your opinion on koha-devel if you think it's a bad idea...
+#
+# Revision 1.178.2.20 2006/10/31 17:20:49 toins
+# * moving bibitemdata from search to here.
+# * using _koha_modify_biblio instead of OLDmodbiblio.
+#
+# Revision 1.178.2.19 2006/10/20 15:26:41 toins
+# sync with dev_week.
+#
+# Revision 1.178.2.18 2006/10/19 11:57:04 btoumi
+# bug fix : wrong syntax in sub call
+#
+# Revision 1.178.2.17 2006/10/17 09:54:42 toins
+# ccode (re)-integration.
+#
+# Revision 1.178.2.16 2006/10/16 16:20:34 toins
+# MARCgetbiblio cleaned up.
+#
+# Revision 1.178.2.15 2006/10/11 14:26:56 tipaul
+# handling of UNIMARC :
+# - better management of field 100 = automatic creation of the field if needed & filling encoding to unicode.
+# - better management of encoding (MARC::File::XML new_from_xml()). This fix works only on my own version of M:F:XML, i think the actual one is buggy & have reported the problem to perl4lib mailing list
+# - fixing a bug on MARCgetitem, that uses biblioitems.marc and not biblioitems.marcxml
+#
+# Revision 1.178.2.14 2006/10/11 07:59:36 tipaul
+# removing hardcoded ccode fiels in biblioitems
+#
+# Revision 1.178.2.13 2006/10/10 14:21:24 toins
+# Biblio.pm now returns a true value.
+#
+# Revision 1.178.2.12 2006/10/09 16:44:23 toins
+# Sync with dev_week.
+#
+# Revision 1.178.2.11 2006/10/06 13:23:49 toins
+# Synch with dev_week.
+#
+# Revision 1.178.2.10 2006/10/02 09:32:02 hdl
+# Adding GetItemStatus and GetItemLocation function in order to make serials-receive.pl work.
+#
+# *************WARNING.***************
+# tested for UNIMARC and using 'marcflavour' system preferences to set defaut_record_format.
+#
+# Revision 1.178.2.9 2006/09/26 07:54:20 hdl
+# Bug FIX: Correct accents for UNIMARC biblio MARC details.
+# (Adding the use of default_record_format in MARCgetbiblio if UNIMARC marcflavour is chosen. This should be widely used as soon as we use xml records)
+#
+# Revision 1.178.2.8 2006/09/25 14:46:22 hdl
+# Now using iso2709 MARC data for MARC.
+# (Works better for accents than XML)
+#
+# Revision 1.178.2.7 2006/09/20 13:44:14 hdl
+# Bug Fixing : Cataloguing was broken for UNIMARC.
+# Please test.
Index: BookShelves.pm
===================================================================
RCS file: /sources/koha/koha/C4/BookShelves.pm,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -b -r1.19 -r1.20
--- BookShelves.pm 6 Nov 2006 21:01:43 -0000 1.19
+++ BookShelves.pm 9 Mar 2007 14:31:47 -0000 1.20
@@ -3,7 +3,7 @@
package C4::BookShelves;
-# $Id: BookShelves.pm,v 1.19 2006/11/06 21:01:43 tgarip1957 Exp $
+# $Id: BookShelves.pm,v 1.20 2007/03/09 14:31:47 tipaul Exp $
# Copyright 2000-2002 Katipo Communications
#
@@ -26,14 +26,10 @@
require Exporter;
use C4::Context;
use C4::Circulation::Circ2;
-use C4::AcademicInfo;
-use C4::Search;
-use C4::Date;
-use C4::Biblio;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.20 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -56,49 +52,21 @@
=cut
@ISA = qw(Exporter);
- at EXPORT = qw(&GetShelfList &GetShelfContents &AddToShelf &AddToShelfFromBiblio
- &RemoveFromShelf &AddShelf &RemoveShelf
- &ShelfPossibleAction
-
- &GetShelfListExt &AddShelfExt &EditShelfExt &RemoveShelfExt
- &GetShelfInfo &GetShelfContentsExt &RemoveFromShelfExt
- &GetShelfListOfExt &AddToShelfExt
-
- &AddRequestToShelf &CountShelfRequest &GetShelfRequests
- &RejectShelfRequest &CatalogueShelfRequest &GetShelfRequestOwner
- &GetShelfRequest);
-
-
-my $dbh;
- $dbh = C4::Context->dbh;
-
-=item ShelfPossibleAction
+ at EXPORT = qw(
+ &GetShelves &GetShelfContents &GetShelf
-=over 4
-
-=item C<$loggedinuser,$shelfnumber,$action>
-
-$action can be "view" or "manage".
-
-Returns 1 if the user can do the $action in the $shelfnumber shelf.
-Returns 0 otherwise.
+ &AddToShelf &AddToShelfFromBiblio &AddShelf
-=back
+ &ModShelf
+ &ShelfPossibleAction
+ &DelFromShelf &DelShelf
+);
-=cut
-sub ShelfPossibleAction {
- my ($loggedinuser,$shelfnumber,$action)= @_;
- my $sth = $dbh->prepare("select owner,category from bookshelf where shelfnumber=?");
- $sth->execute($shelfnumber);
- my ($owner,$category) = $sth->fetchrow;
- return 1 if (($category>=3 or $owner eq $loggedinuser) && $action eq 'manage');
- return 1 if (($category>= 2 or $owner eq $loggedinuser) && $action eq 'view');
- return 0;
-}
+my $dbh = C4::Context->dbh;
-=item GetShelfList
+=item GetShelves
- $shelflist = &GetShelfList();
+ $shelflist = &GetShelves($owner, $mincategory);
($shelfnumber, $shelfhash) = each %{$shelflist};
Looks up the virtual bookshelves, and returns a summary. C<$shelflist>
@@ -106,6 +74,9 @@
(C<$shelfnumber>, above), and the values (C<$shelfhash>, above) are
themselves references-to-hash, with the following keys:
+C<mincategory> : 2 if the list is for "look". 3 if the list is for "Select bookshelf for adding a book".
+bookshelves of the owner are always selected, whatever the category
+
=over 4
=item C<$shelfhash-E<gt>{shelfname}>
@@ -119,155 +90,242 @@
=back
=cut
+
#'
# FIXME - Wouldn't it be more intuitive to return a list, rather than
# a reference-to-hash? The shelf number can be just another key in the
# hash.
-sub GetShelfList {
- my ($owner,$mincategory) = @_;
- # mincategory : 2 if the list is for "look". 3 if the list is for "Select bookshelf for adding a book".
- # bookshelves of the owner are always selected, whatever the category
- my $sth=$dbh->prepare("SELECT bookshelf.shelfnumber, bookshelf.shelfname,owner,surname,firstname, category,
+
+sub GetShelves {
+ my ( $owner, $mincategory ) = @_;
+
+ my $query = qq(
+ SELECT bookshelf.shelfnumber, bookshelf.shelfname,owner,surname,firstname,bookshelf.category,
count(shelfcontents.itemnumber) as count
FROM bookshelf
- LEFT JOIN shelfcontents
- ON bookshelf.shelfnumber = shelfcontents.shelfnumber
- left join borrowers on bookshelf.owner = borrowers.borrowernumber
-
- where owner=? or category>=?
- GROUP BY bookshelf.shelfnumber order by shelfname");
- $sth->execute($owner,$mincategory);
+ LEFT JOIN shelfcontents ON bookshelf.shelfnumber = shelfcontents.shelfnumber
+ LEFT JOIN borrowers ON bookshelf.owner = borrowers.borrowernumber
+ WHERE owner=? OR category>=?
+ GROUP BY bookshelf.shelfnumber
+ ORDER BY bookshelf.category, bookshelf.shelfname, borrowers.firstname, borrowers.surname
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $owner, $mincategory );
my %shelflist;
- while (my ($shelfnumber, $shelfname,$owner,$surname,$firstname,$category,$count) = $sth->fetchrow) {
- $shelflist{$shelfnumber}->{'shelfname'}=$shelfname;
- $shelflist{$shelfnumber}->{'count'}=$count;
- $shelflist{$shelfnumber}->{'owner'}=$owner;
+ while (
+ my (
+ $shelfnumber, $shelfname, $owner, $surname,
+ $firstname, $category, $count
+ )
+ = $sth->fetchrow
+ )
+ {
+ $shelflist{$shelfnumber}->{'shelfname'} = $shelfname;
+ $shelflist{$shelfnumber}->{'count'} = $count;
+ $shelflist{$shelfnumber}->{'category'} = $category;
+ $shelflist{$shelfnumber}->{'owner'} = $owner;
$shelflist{$shelfnumber}->{'surname'} = $surname;
$shelflist{$shelfnumber}->{'firstname'} = $firstname;
- $shelflist{$shelfnumber}->{'category'} = $category;
+ }
+ return ( \%shelflist );
+}
+=item GetShef
- }
+ (shelfnumber,shelfname,owner,category) = &GetShelf($shelfnumber);
+
+Looks up information about the contents of virtual bookshelf number
+C<$shelfnumber>
+
+Returns the database's information on 'bookshelf' table.
+
+=cut
- return(\%shelflist);
+sub GetShelf {
+ my ($shelfnumber) = @_;
+ my $query = qq(
+ SELECT shelfnumber,shelfname,owner,category
+ FROM bookshelf
+ WHERE shelfnumber=?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute($shelfnumber);
+ return $sth->fetchrow;
}
=item GetShelfContents
- $itemlist = &GetShelfContents($env, $shelfnumber);
+ $itemlist = &GetShelfContents($shelfnumber);
Looks up information about the contents of virtual bookshelf number
C<$shelfnumber>.
Returns a reference-to-array, whose elements are references-to-hash,
-as returned by C<&getiteminformation>.
-
-I don't know what C<$env> is.
+as returned by C<C4::Circ2::getiteminformation>.
=cut
+
#'
sub GetShelfContents {
- my ($env, $shelfnumber) = @_;
+ my ( $shelfnumber ) = @_;
my @itemlist;
- my $sth=$dbh->prepare("select itemnumber from shelfcontents where shelfnumber=? order by itemnumber");
+ my $query =
+ " SELECT itemnumber
+ FROM shelfcontents
+ WHERE shelfnumber=?
+ ORDER BY itemnumber
+ ";
+ my $sth = $dbh->prepare($query);
$sth->execute($shelfnumber);
- while (my ($itemnumber) = $sth->fetchrow) {
- my ($item) = getiteminformation($env, $itemnumber, 0);
- push (@itemlist, $item);
+ my $sth2 = $dbh->prepare("
+ SELECT biblio.*,biblioitems.* FROM items
+ LEFT JOIN biblio on items.biblionumber=biblio.biblionumber
+ LEFT JOIN biblioitems on items.biblionumber=biblioitems.biblionumber
+ WHERE items.itemnumber=?"
+ );
+ while ( my ($itemnumber) = $sth->fetchrow ) {
+ $sth2->execute($itemnumber);
+ my $item = $sth2->fetchrow_hashref;
+ $item->{'itemnumber'}=$itemnumber;
+ push( @itemlist, $item );
+ }
+ return ( \@itemlist );
+}
+
+=item AddShelf
+
+ $shelfnumber = &AddShelf( $shelfname, $owner, $category);
+
+Creates a new virtual bookshelf with name C<$shelfname>, owner C<$owner> and category
+C<$category>.
+
+Returns a code to know what's happen.
+ * -1 : if this bookshelf already exist.
+ * $shelfnumber : if success.
+
+=cut
+
+sub AddShelf {
+ my ( $shelfname, $owner, $category ) = @_;
+ my $query = qq(
+ SELECT *
+ FROM bookshelf
+ WHERE shelfname=? AND owner=?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute($shelfname,$owner);
+ if ( $sth->rows ) {
+ return (-1);
+ }
+ else {
+ my $query = qq(
+ INSERT INTO bookshelf
+ (shelfname,owner,category)
+ VALUES (?,?,?)
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute( $shelfname, $owner, $category );
+ my $shelfnumber = $dbh->{'mysql_insertid'};
+ return ($shelfnumber);
}
- return (\@itemlist);
}
=item AddToShelf
- &AddToShelf($env, $itemnumber, $shelfnumber);
+ &AddToShelf($itemnumber, $shelfnumber);
Adds item number C<$itemnumber> to virtual bookshelf number
C<$shelfnumber>, unless that item is already on that shelf.
-C<$env> is ignored.
-
=cut
+
#'
sub AddToShelf {
- my ($env, $itemnumber, $shelfnumber) = @_;
+ my ( $itemnumber, $shelfnumber ) = @_;
return unless $itemnumber;
- my $sth=$dbh->prepare("select * from shelfcontents where shelfnumber=? and itemnumber=?");
+ my $query = qq(
+ SELECT *
+ FROM shelfcontents
+ WHERE shelfnumber=? AND itemnumber=?
+ );
+ my $sth = $dbh->prepare($query);
- $sth->execute($shelfnumber, $itemnumber);
- if ($sth->rows) {
-# already on shelf
- } else {
- $sth=$dbh->prepare("insert into shelfcontents (shelfnumber, itemnumber, flags) values (?, ?, 0)");
- $sth->execute($shelfnumber, $itemnumber);
+ $sth->execute( $shelfnumber, $itemnumber );
+ unless ( $sth->rows ) {
+ # already on shelf
+ my $query = qq(
+ INSERT INTO shelfcontents
+ (shelfnumber, itemnumber, flags)
+ VALUES
+ (?, ?, 0)
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute( $shelfnumber, $itemnumber );
}
}
+
+=item AddToShelfFromBiblio
+
+ &AddToShelfFromBiblio($biblionumber, $shelfnumber)
+
+ this function allow to add a book into the shelf number $shelfnumber
+ from biblionumber.
+
+=cut
+
sub AddToShelfFromBiblio {
- my ($env, $biblionumber, $shelfnumber) = @_;
+ my ( $biblionumber, $shelfnumber ) = @_;
return unless $biblionumber;
- my $sth = $dbh->prepare("select itemnumber from items where biblionumber=?");
+ my $query = qq(
+ SELECT itemnumber
+ FROM items
+ WHERE biblionumber=?
+ );
+ my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
my ($itemnumber) = $sth->fetchrow;
- $sth=$dbh->prepare("select * from shelfcontents where shelfnumber=? and itemnumber=?");
- $sth->execute($shelfnumber, $itemnumber);
- if ($sth->rows) {
-# already on shelf
- } else {
- $sth=$dbh->prepare("insert into shelfcontents (shelfnumber, itemnumber, flags,biblionumber) values (?, ?, 0,?)");
- $sth->execute($shelfnumber, $itemnumber,$biblionumber);
+ $query = qq(
+ SELECT *
+ FROM shelfcontents
+ WHERE shelfnumber=? AND itemnumber=?
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute( $shelfnumber, $itemnumber );
+ unless ( $sth->rows ) {
+ # "already on shelf";
+ my $query =qq(
+ INSERT INTO shelfcontents
+ (shelfnumber, itemnumber, flags)
+ VALUES
+ (?, ?, 0)
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute( $shelfnumber, $itemnumber );
}
}
-=item RemoveFromShelf
+=item ModShelf
- &RemoveFromShelf($env, $itemnumber, $shelfnumber);
+ModShelf($shelfnumber, $shelfname, $owner, $category )
-Removes item number C<$itemnumber> from virtual bookshelf number
-C<$shelfnumber>. If the item wasn't on that bookshelf to begin with,
-nothing happens.
-
-C<$env> is ignored.
+Modify the value into bookshelf table with values given on input arg.
=cut
-#'
-sub RemoveFromShelf {
- my ($env, $itemnumber, $shelfnumber) = @_;
- my $sth=$dbh->prepare("delete from shelfcontents where shelfnumber=? and itemnumber=?");
- $sth->execute($shelfnumber,$itemnumber);
-}
-=item AddShelf
-
- ($status, $msg) = &AddShelf($env, $shelfname);
-
-Creates a new virtual bookshelf with name C<$shelfname>.
-
-Returns a two-element array, where C<$status> is 0 if the operation
-was successful, or non-zero otherwise. C<$msg> is "Done" in case of
-success, or an error message giving the reason for failure.
-
-C<$env> is ignored.
-
-=cut
-#'
-# FIXME - Perhaps this could/should return the number of the new bookshelf
-# as well?
-sub AddShelf {
- my ($env, $shelfname,$owner,$category) = @_;
- my $sth=$dbh->prepare("select * from bookshelf where shelfname=?");
- $sth->execute($shelfname);
- if ($sth->rows) {
- return(1, "Shelf \"$shelfname\" already exists");
- } else {
- $sth=$dbh->prepare("insert into bookshelf (shelfname,owner,category) values (?,?,?)");
- $sth->execute($shelfname,$owner,$category);
- return (0, "Done");
- }
+sub ModShelf {
+ my ( $shelfnumber, $shelfname, $owner, $category ) = @_;
+ my $query = qq(
+ UPDATE bookshelf
+ SET shelfname=?,owner=?,category=?
+ WHERE shelfnumber=?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $shelfname, $owner, $category, $shelfnumber );
}
-=item RemoveShelf
+=item DelShelf
- ($status, $msg) = &RemoveShelf($env, $shelfnumber);
+ ($status) = &DelShelf($shelfnumber);
Deletes virtual bookshelf number C<$shelfnumber>. The bookshelf must
be empty.
@@ -276,402 +334,133 @@
was successful, or non-zero otherwise. C<$msg> is "Done" in case of
success, or an error message giving the reason for failure.
-C<$env> is ignored.
-
=cut
-#'
-sub RemoveShelf {
- my ($env, $shelfnumber) = @_;
- my $sth=$dbh->prepare("select count(*) from shelfcontents where shelfnumber=?");
- $sth->execute($shelfnumber);
- my ($count)=$sth->fetchrow;
- if ($count) {
- return (1, "Shelf has $count items on it. Please remove all items before deleting this shelf.");
- } else {
- $sth=$dbh->prepare("delete from bookshelf where shelfnumber=?");
- $sth->execute($shelfnumber);
- return (0, "Done");
- }
-}
-sub GetShelfListOfExt {
- my ($owner) = @_;
- my $sth;
- if ($owner) {
- $sth = $dbh->prepare("SELECT * FROM bookshelf WHERE (owner = ?) or category>=2 ORDER BY shelfname");
- $sth->execute($owner);
- } else {
- $sth = $dbh->prepare("SELECT * FROM bookshelf where category<2 ORDER BY shelfname");
- $sth->execute();
- }
-
- my $sth2 = $dbh->prepare("SELECT count(biblionumber) as bibliocount FROM shelfcontents WHERE (shelfnumber = ?)");
-
- my @results;
- while (my $row = $sth->fetchrow_hashref) {
- $sth2->execute($row->{'shelfnumber'});
- $row->{'bibliocount'} = $sth2->fetchrow;
- if ($row->{'category'} == 1) {
- $row->{'private'} = 1;
- } else {
- $row->{'public'} = 1;
- }
- push @results, $row;
- }
- return \@results;
-}
-sub GetShelfListExt {
- my ($owner,$mincategory,$id_intitution, $intra) = @_;
-
- my $sth1 = $dbh->prepare("SELECT * FROM careers WHERE id_institution = ?");
- $sth1->execute($id_intitution);
- my @results;
-
- my $total_shelves = 0;
- while (my $row1 = $sth1->fetchrow_hashref) {
-
- my @shelves;
- my $sth2;
- if ($intra) {
- $sth2=$dbh->prepare("SELECT
- bookshelf.shelfnumber, bookshelf.shelfname,owner,surname,firstname, category,
- count(shelfcontents.biblionumber) as count
- FROM
- bookshelf
- LEFT JOIN shelfcontents ON bookshelf.shelfnumber = shelfcontents.shelfnumber
- LEFT JOIN borrowers ON bookshelf.owner = borrowers.borrowernumber
- LEFT JOIN bookshelves_careers ON bookshelves_careers.shelfnumber = bookshelf.shelfnumber
- WHERE
- (id_career = ?)
- GROUP BY bookshelf.shelfnumber
- ORDER BY shelfname");
- $sth2->execute($row1->{'id_career'});
-
- } else {
- $sth2=$dbh->prepare("SELECT
- bookshelf.shelfnumber, bookshelf.shelfname,owner,surname,firstname, category,
- count(shelfcontents.biblionumber) as count
- FROM
- bookshelf
- LEFT JOIN shelfcontents ON bookshelf.shelfnumber = shelfcontents.shelfnumber
- LEFT JOIN borrowers ON bookshelf.owner = borrowers.borrowernumber
- LEFT JOIN bookshelves_careers ON bookshelves_careers.shelfnumber = bookshelf.shelfnumber
- WHERE
- (owner = ? OR category >= ?) AND (id_career = ?)
- GROUP BY bookshelf.shelfnumber
- ORDER BY shelfname");
- $sth2->execute($owner,$mincategory,$row1->{'id_career'});
- }
+=item ShelfPossibleAction
- $row1->{'shelfcount'} = 0;
- while (my $row2 = $sth2->fetchrow_hashref) {
- if ($owner == $row2->{'owner'}) {
- $row2->{'canmanage'} = 1;
- }
- if ($row2->{'category'} == 1) {
- $row2->{'private'} = 1;
- } else {
- $row2->{'public'} = 1;
- }
- $row1->{'shelfcount'}++;
- $total_shelves++;
- push @shelves, $row2;
- }
- $row1->{'shelvesloop'} = \@shelves;
- push @results, $row1;
- }
+ShelfPossibleAction($loggedinuser, $shelfnumber, $action);
- return($total_shelves, \@results);
-}
+C<$loggedinuser,$shelfnumber,$action>
-sub AddShelfExt {
- my ($shelfname,$owner,$category,$careers) = @_;
- my $sth = $dbh->prepare("SELECT * FROM bookshelf WHERE shelfname = ?");
- $sth->execute($shelfname);
- if ($sth->rows) {
- return 0;
- } else {
- $sth = $dbh->prepare("INSERT INTO bookshelf (shelfname,owner,category) VALUES (?,?,?)");
- $sth->execute($shelfname,$owner,$category);
- my $shelfnumber = $dbh->{'mysql_insertid'};
+$action can be "view" or "manage".
- foreach my $row (@{$careers}) {
- $sth = $dbh->prepare("INSERT INTO bookshelves_careers VALUES (?,?)");
- $sth->execute($shelfnumber, $row);
- }
- return $shelfnumber;
- }
-}
+Returns 1 if the user can do the $action in the $shelfnumber shelf.
+Returns 0 otherwise.
-sub EditShelfExt {
- my ($shelfnumber,$shelfname,$category,$careers) = @_;
- my $sth = $dbh->prepare("SELECT * FROM bookshelf WHERE shelfname = ? AND NOT shelfnumber = ? ");
- $sth->execute($shelfname, $shelfnumber);
- if ($sth->rows) {
- return 0;
- } else {
- $sth = $dbh->prepare("UPDATE bookshelf SET shelfname = ?, category = ? WHERE shelfnumber = ?");
- $sth->execute($shelfname,$category,$shelfnumber);
+=cut
- $sth = $dbh->prepare("DELETE FROM bookshelves_careers WHERE shelfnumber = ?");
+sub ShelfPossibleAction {
+ my ( $user, $shelfnumber, $action ) = @_;
+ my $query = qq(
+ SELECT owner,category
+ FROM bookshelf
+ WHERE shelfnumber=?
+ );
+ my $sth = $dbh->prepare($query);
$sth->execute($shelfnumber);
-
- foreach my $row (@{$careers}) {
- $sth = $dbh->prepare("INSERT INTO bookshelves_careers VALUES (?,?)");
- $sth->execute($shelfnumber, $row);
- }
- return $shelfnumber;
- }
+ my ( $owner, $category ) = $sth->fetchrow;
+ return 1 if (($category >= 3 or $owner eq $user) && $action eq 'manage' );
+ return 1 if (($category >= 2 or $owner eq $user) && $action eq 'view' );
+ return 0;
}
+=item DelFromShelf
-sub RemoveShelfExt {
- my ($shelfnumber) = @_;
- my $sth = $dbh->prepare("DELETE FROM bookshelves_careers WHERE shelfnumber = ?");
- $sth->execute($shelfnumber);
- my $sth = $dbh->prepare("DELETE FROM shelfcontents WHERE shelfnumber = ?");
- $sth->execute($shelfnumber);
- $sth = $dbh->prepare("DELETE FROM bookshelf WHERE shelfnumber = ?");
- $sth->execute($shelfnumber);
- return 1;
-}
+ &DelFromShelf( $itemnumber, $shelfnumber);
-sub GetShelfInfo {
- my ($shelfnumber, $owner) = @_;
- my $sth = $dbh->prepare("SELECT * FROM bookshelf WHERE shelfnumber = ?");
- $sth->execute($shelfnumber);
- my $result = $sth->fetchrow_hashref;
+Removes item number C<$itemnumber> from virtual bookshelf number
+C<$shelfnumber>. If the item wasn't on that bookshelf to begin with,
+nothing happens.
- if ($result->{'owner'} == $owner) {
- $result->{'canmanage'} = 1;
- }
+=cut
- my $sth = $dbh->prepare("SELECT id_career FROM bookshelves_careers WHERE shelfnumber = ?");
- $sth->execute($shelfnumber);
- my @careers;
- while (my $row = $sth->fetchrow) {
- push @careers, $row;
- }
- $result->{'careers'} = \@careers;
- return $result;
+#'
+sub DelFromShelf {
+ my ( $itemnumber, $shelfnumber ) = @_;
+ my $query = qq(
+ DELETE FROM shelfcontents
+ WHERE shelfnumber=? AND itemnumber=?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $shelfnumber, $itemnumber );
}
-sub GetShelfContentsExt {
- my ($shelfnumber) = @_;
- my $sth = $dbh->prepare("SELECT biblionumber FROM shelfcontents WHERE shelfnumber = ? ORDER BY biblionumber");
- $sth->execute($shelfnumber);
- my @biblios;
- my $even = 0;
- while (my ($biblionumber) = $sth->fetchrow) {
- my $biblio=ZEBRA_readyXML_noheader($dbh,$biblionumber);
- my $xmlrecord=XML_xml2hash($biblio);
- push @biblios,$xmlrecord;
- }
-my ($facets, at results)=parsefields($dbh,"opac", at biblios);
+=head2 DelShelf
- return (\@results);
-}
+ $Number = DelShelf($shelfnumber);
-sub RemoveFromShelfExt {
- my ($biblionumber, $shelfnumber) = @_;
- my $sth = $dbh->prepare("DELETE FROM shelfcontents WHERE shelfnumber = ? AND biblionumber = ?");
- $sth->execute($shelfnumber,$biblionumber);
-}
+ this function delete the shelf number, and all of it's content
-sub AddToShelfExt {
- my ($biblionumber, $shelfnumber) = @_;
- my $sth = $dbh->prepare("SELECT * FROM shelfcontents WHERE shelfnumber = ? AND biblionumber = ?");
- $sth->execute($shelfnumber, $biblionumber);
- if ($sth->rows) {
- return 0
- } else {
- $sth = $dbh->prepare("INSERT INTO shelfcontents (shelfnumber, biblionumber) VALUES (?, ?)");
- $sth->execute($shelfnumber, $biblionumber);
- }
-}
+=cut
-sub AddRequestToShelf {
- my ($shelfnumber, $requestType, $requestName, $comments) = @_;
- my $sth = $dbh->prepare("INSERT INTO shelf_requests (shelfnumber, request_name, request_type, status, request_date, comments) VALUES (?,?,?,?, CURRENT_DATE(),?)");
- $sth->execute($shelfnumber, $requestName, $requestType, "PENDING", $comments);
- return $dbh->{'mysql_insertid'};
+#'
+sub DelShelf {
+ my ( $shelfnumber ) = @_;
+ my $sth = $dbh->prepare("DELETE FROM bookshelf WHERE shelfnumber=?");
+ $sth->execute($shelfnumber);
+ return 0;
}
-sub CountShelfRequest {
- my ($shelfnumber, $status) = @_;
- my $sth;
- if ($shelfnumber) {
- $sth = $dbh->prepare("SELECT count(idRequest) FROM shelf_requests WHERE shelfnumber = ? AND status = ?");
- $sth->execute($shelfnumber, $status);
- } else {
- $sth = $dbh->prepare("SELECT count(idRequest) FROM shelf_requests WHERE status = ?");
- $sth->execute($status);
- }
- my ($count) = $sth->fetchrow_array;
- return $count;
-}
+END { } # module clean-up code here (global destructor)
-sub GetShelfRequests {
- my ($shelfnumber, $status, $type) = @_;
- my @params;
- my $query = "SELECT * FROM shelf_requests SR INNER JOIN bookshelf BS ON SR.shelfnumber = BS.shelfnumber WHERE status = ?";
- push @params, $status;
- if ($shelfnumber) {
- $query.= " AND shelfnumber = ?";
- push @params, $shelfnumber;
- }
- if ($type) {
- $query.= " AND request_type = ?";
- push @params, $type;
- }
- $query.= " ORDER BY SR.shelfnumber, SR.request_date";
- my $sth = $dbh->prepare($query);
- $sth->execute(@params);
- my @results;
+1;
- my $color = 0;
- while (my $row = $sth->fetchrow_hashref) {
- my $borrdata = borrdata('',$row->{'owner'});
- $row->{'surname'} = $borrdata->{'surname'};
- $row->{'firstname'} = $borrdata->{'firstname'};
- $row->{'cardnumber'} = $borrdata->{'cardnumber'};
- $row->{'request_date'} = format_date($row->{'request_date'});
- $row->{$row->{'request_type'}} = 1;
- $row->{$row->{'status'}} = 1;
- $row->{'color'} = $color = not $color;
- push @results, $row;
- }
- return (\@results);
-}
+__END__
-sub RejectShelfRequest {
- my ($idRequest) = @_;
- #get the type and name request
- my $sth = $dbh->prepare("SELECT request_type, request_name FROM shelf_requests WHERE idRequest = ?");
- $sth->execute($idRequest);
- my ($request_type, $request_name) = $sth->fetchrow_array;
- #if the request is a file, then unlink the file
- if ($request_type eq 'file') {
- unlink($ENV{'DOCUMENT_ROOT'}."/uploaded-files/shelf-files/$idRequest-$request_name");
- }
- #change tha request status to REJECTED
- $sth = $dbh->prepare("UPDATE shelf_requests SET status = ? WHERE idRequest = ?");
- $sth->execute("REJECTED", $idRequest);
- return 1;
-}
+=back
-sub GetShelfRequestOwner {
- my ($idRequest) = @_;
- my $sth = $dbh->prepare("SELECT owner FROM shelf_requests R INNER JOIN bookshelf S ON R.shelfnumber = S.shelfnumber WHERE idRequest = ?");
- $sth->execute($idRequest);
- my ($owner) = $sth->fetchrow_array;
- my $bordata = &borrdata(undef, $owner);
- #print "Content-type: text/plain \n\n --- $owner ----- $bordata->{'emailaddress'}" ;
- return ($bordata);
-}
+=head1 AUTHOR
-sub GetShelfRequest {
- my ($idRequest) = @_;
- my $sth = $dbh->prepare("SELECT * FROM shelf_requests R INNER JOIN bookshelf S ON R.shelfnumber = S.shelfnumber WHERE idRequest = ?");
- $sth->execute($idRequest);
- my $request_data = $sth->fetchrow_hashref;
- return $request_data;
-}
+Koha Developement team <info at koha.org>
-sub CatalogueShelfRequest {
- my ($idRequest, $shelfnumber, $biblionumber) = @_;
- #find the last request status
- my $sth = $dbh->prepare("SELECT status, biblionumber FROM shelf_requests WHERE idRequest = ?");
- $sth->execute($idRequest);
- my ($prev_status, $prev_biblionumber) = $sth->fetchrow_array;
- #if the status was not seted, inserts an entry in shelfcontents
- if ($prev_status ne "CATALOGUED") {
- $sth = $dbh->prepare("INSERT INTO shelfcontents (shelfnumber, biblionumber) VALUES (?,?)");
- $sth->execute($shelfnumber, $biblionumber);
- #if the request was previously catalogued, delete the entry in shelfcontens
- } elsif ($prev_status ne "REJECTED") {
- $sth = $dbh->prepare("DELETE FROM shelfcontents WHERE shelfnumber = ? AND biblionumber = ?");
- $sth->execute($shelfnumber, $prev_biblionumber);
- }
- #change the status to catalogued
- $sth = $dbh->prepare("UPDATE shelf_requests SET status = ?, biblionumber = ? WHERE idRequest = ?");
- $sth->execute("CATALOGUED", $biblionumber, $idRequest);
- return 1;
-}
+=head1 SEE ALSO
-END { } # module clean-up code here (global destructor)
+C4::Circulation::Circ2(3)
-1;
+=cut
#
# $Log: BookShelves.pm,v $
-# Revision 1.19 2006/11/06 21:01:43 tgarip1957
-# Bug fixing and complete removal of Date::Manip
-#
-# Revision 1.18 2006/09/06 16:21:03 tgarip1957
-# Clean up before final commits
+# Revision 1.20 2007/03/09 14:31:47 tipaul
+# rel_3_0 moved to HEAD
#
-# Revision 1.13 2004/03/11 16:06:20 tipaul
-# *** empty log message ***
+# Revision 1.15.8.10 2007/01/25 13:18:15 tipaul
+# checking that a bookshelf with the same name AND OWNER does not exist before creating it
#
-# Revision 1.11.2.2 2004/02/19 10:15:41 tipaul
-# new feature : adding book to bookshelf from biblio detail screen.
+# Revision 1.15.8.9 2006/12/15 17:37:52 toins
+# removing a function used only once.
#
-# Revision 1.11.2.1 2004/02/06 14:16:55 tipaul
-# fixing bugs in bookshelves management.
+# Revision 1.15.8.8 2006/12/14 17:22:55 toins
+# bookshelves work perfectly with mod_perl and are cleaned.
#
-# Revision 1.11 2003/12/15 10:57:08 slef
-# DBI call fix for bug 662
+# Revision 1.15.8.7 2006/12/13 19:46:41 hdl
+# Some bug fixing.
#
-# Revision 1.10 2003/02/05 10:05:02 acli
-# Converted a few SQL statements to use ? to fix a few strange SQL errors
-# Noted correct tab size
+# Revision 1.15.8.6 2006/12/11 17:10:06 toins
+# fixing some bugs on bookshelves.
#
-# Revision 1.9 2002/10/13 08:29:18 arensb
-# Deleted unused variables.
-# Removed trailing whitespace.
+# Revision 1.15.8.5 2006/12/07 16:45:43 toins
+# removing warn compilation. (perl -wc)
#
-# Revision 1.8 2002/10/10 04:32:44 arensb
-# Simplified references.
+# Revision 1.15.8.4 2006/11/23 09:05:01 tipaul
+# enable removal of a bookshelf even if there are items inside
#
-# Revision 1.7 2002/10/05 09:50:10 arensb
-# Merged with arensb-context branch: use C4::Context->dbh instead of
-# &C4Connect, and generally prefer C4::Context over C4::Database.
+# Revision 1.15.8.3 2006/10/30 09:50:20 tipaul
+# removing getiteminformations (using direct SQL, as we are in a .pm, so it's "legal")
#
-# Revision 1.6.2.1 2002/10/04 02:24:43 arensb
-# Use C4::Connect instead of C4::Database, C4::Connect->dbh instead
-# C4Connect.
+# Revision 1.15.8.2 2006/08/31 16:03:52 toins
+# Add Pod to DelShelf
#
-# Revision 1.6 2002/09/23 13:50:30 arensb
-# Fixed missing bit in POD.
+# Revision 1.15.8.1 2006/08/30 15:59:14 toins
+# Code cleaned according to coding guide lines.
#
-# Revision 1.5 2002/09/22 17:29:17 arensb
-# Added POD.
-# Added some FIXME comments.
-# Removed useless trailing whitespace.
+# Revision 1.15 2004/12/16 11:30:58 tipaul
+# adding bookshelf features :
+# * create bookshelf on the fly
+# * modify a bookshelf name & status
#
-# Revision 1.4 2002/08/14 18:12:51 tonnesen
-# Added copyright statement to all .pl and .pm files
-#
-# Revision 1.3 2002/07/02 17:48:06 tonnesen
-# Merged in updates from rel-1-2
-#
-# Revision 1.2.2.1 2002/06/26 20:46:48 tonnesen
-# Inserting some changes I made locally a while ago.
-#
-#
-
-__END__
-
-=back
-
-=head1 AUTHOR
-
-Koha Developement team <info at koha.org>
-
-=head1 SEE ALSO
-
-C4::Circulation::Circ2(3)
-
-=cut
+# Revision 1.14 2004/12/15 17:28:23 tipaul
+# adding bookshelf features :
+# * create bookshelf on the fly
+# * modify a bookshelf (this being not finished, will commit the rest soon)
Index: Bookfund.pm
===================================================================
RCS file: /sources/koha/koha/C4/Bookfund.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -b -r1.7 -r1.8
--- Bookfund.pm 20 Sep 2006 21:48:44 -0000 1.7
+++ Bookfund.pm 9 Mar 2007 14:31:47 -0000 1.8
@@ -17,7 +17,7 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Bookfund.pm,v 1.7 2006/09/20 21:48:44 tgarip1957 Exp $
+# $Id: Bookfund.pm,v 1.8 2007/03/09 14:31:47 tipaul Exp $
use strict;
@@ -25,7 +25,7 @@
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.7 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+$VERSION = do { my @v = '$Revision: 1.8 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -55,15 +55,11 @@
=head1 FUNCTIONS
-=over 2
-
=cut
#-------------------------------------------------------------#
-=head3 GetBookFund
-
-=over 4
+=head2 GetBookFund
$dataaqbookfund = &GetBookFund($bookfundid);
@@ -73,12 +69,12 @@
C<$dataaqbookfund> is a hashref full of bookfundid, bookfundname, bookfundgroup,
and branchcode.
-=back
-
=cut
sub GetBookFund {
my $bookfundid = shift;
+ my $branchcode = shift;
+ $branchcode=($branchcode?$branchcode:'');
my $dbh = C4::Context->dbh;
my $query = "
SELECT
@@ -88,17 +84,16 @@
branchcode
FROM aqbookfund
WHERE bookfundid = ?
- ";
+ AND branchcode = ?";
my $sth=$dbh->prepare($query);
-$sth->execute($bookfundid);
- return $sth->fetchrow_hashref;
+ $sth->execute($bookfundid,$branchcode);
+ my $data=$sth->fetchrow_hashref;
+ return $data;
}
=head3 GetBookFundsId
-=over 4
-
$sth = &GetBookFundsId
Read on aqbookfund table and execute a simple SQL query.
@@ -108,15 +103,13 @@
C<@results> is an array of id existing on the database.
-=back
-
=cut
sub GetBookFundsId {
my @bookfundids_loop;
my $dbh= C4::Context->dbh;
my $query = "
- SELECT bookfundid
+ SELECT bookfundid,branchcode
FROM aqbookfund
";
my $sth = $dbh->prepare($query);
@@ -128,8 +121,6 @@
=head3 GetBookFunds
-=over 4
-
@results = &GetBookFunds;
Returns a list of all book funds.
@@ -137,25 +128,22 @@
C<@results> is an array of references-to-hash, whose keys are fields from the aqbookfund and aqbudget tables of the Koha database. Results are ordered
alphabetically by book fund name.
-=back
-
=cut
sub GetBookFunds {
my ($branch) = @_;
my $dbh = C4::Context->dbh;
my $userenv = C4::Context->userenv;
- my $branch = $userenv->{branch};
my $strsth;
- if ( $branch ) {
+ if ( $branch ne '' ) {
$strsth = "
SELECT *
FROM aqbookfund,aqbudget
WHERE aqbookfund.bookfundid=aqbudget.bookfundid
- AND startdate<=now()
+ AND startdate<now()
AND enddate>now()
- AND (aqbookfund.branchcode IS NULL OR aqbookfund.branchcode='' OR aqbookfund.branchcode= ? )
+ AND (aqbookfund.branchcode='' OR aqbookfund.branchcode= ? )
GROUP BY aqbookfund.bookfundid ORDER BY bookfundname";
}
else {
@@ -170,7 +158,7 @@
";
}
my $sth = $dbh->prepare($strsth);
- if ( $branch ) {
+ if ( $branch ne '' ) {
$sth->execute($branch);
}
else {
@@ -188,8 +176,6 @@
=head3 GetCurrencies
-=over 4
-
@currencies = &GetCurrencies;
Returns the list of all known currencies.
@@ -197,8 +183,6 @@
C<$currencies> is a array; its elements are references-to-hash, whose
keys are the fields from the currency table in the Koha database.
-=back
-
=cut
sub GetCurrencies {
@@ -221,15 +205,11 @@
=head3 GetBookFundBreakdown
-=over 4
-
( $spent, $comtd ) = &GetBookFundBreakdown( $id, $year, $start, $end );
returns the total comtd & spent for a given bookfund, and a given year
used in acqui-home.pl
-=back
-
=cut
sub GetBookFundBreakdown {
@@ -262,8 +242,8 @@
}
else {
- my $leftover = $data->{'quantity'} - $data->{'quantityreceived'};
- $spent += ( $data->{'unitprice'} ) * $data->{'quantityreceived'};
+ my $leftover = $data->{'quantity'} - ($data->{'quantityreceived'}?$data->{'quantityreceived'}:0);
+ $spent += ( $data->{'unitprice'} ) * ($data->{'quantityreceived'}?$data->{'quantityreceived'}:0);
}
}
@@ -271,10 +251,10 @@
# then do a seperate query for commited totals, (pervious single query was
# returning incorrect comitted results.
- my $query = "
+ $query = "
SELECT quantity,datereceived,freight,unitprice,
listprice,ecost,quantityreceived AS qrev,
- subscription,biblio.title,itemtype,aqorders.biblionumber,
+ subscription,title,itemtype,aqorders.biblionumber,
aqorders.booksellerinvoicenumber,
quantity-quantityreceived AS tleft,
aqorders.ordernumber AS ordnum,entrydate,budgetdate,
@@ -282,7 +262,7 @@
FROM aqorderbreakdown,
aqbasket,
aqorders
- LEFT JOIN biblio ON biblio.biblionumber=aqorders.biblionumber
+ LEFT JOIN biblioitems ON biblioitems.biblioitemnumber=aqorders.biblioitemnumber
WHERE bookfundid=?
AND aqorders.ordernumber=aqorderbreakdown.ordernumber
AND aqorders.basketno=aqbasket.basketno
@@ -290,7 +270,7 @@
AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')
";
- my $sth = $dbh->prepare($query);
+ $sth = $dbh->prepare($query);
$sth->execute( $id, $start, $end );
my $comtd;
@@ -315,14 +295,10 @@
=head3 NewBookFund
-=over 4
-
&NewBookFund(bookfundid, bookfundname, branchcode);
this function create a new bookfund into the database.
-=back
-
=cut
sub NewBookFund{
@@ -337,34 +313,31 @@
(?, ?, ?)
";
my $sth=$dbh->prepare($query);
- $sth->execute($bookfundid,$bookfundname,$branchcode);
+ $sth->execute($bookfundid,$bookfundname,"$branchcode");
}
#-------------------------------------------------------------#
=head3 ModBookFund
-=over 4
-
&ModBookFund($bookfundname,$branchcode,$bookfundid);
this function update the bookfundname and the branchcode on aqbookfund table
on database.
-=back
-
=cut
sub ModBookFund {
- my ($bookfundname,$branchcode,$bookfundid) = @_;
+ my ($bookfundname,$bookfundid,$branchcode) = @_;
my $dbh = C4::Context->dbh;
my $query = "
UPDATE aqbookfund
- SET bookfundname = ?,
- branchcode = ?
+ SET bookfundname = ?
WHERE bookfundid = ?
+ AND branchcode= ?
";
+ warn "name : $bookfundname";
my $sth=$dbh->prepare($query);
- $sth->execute($bookfundname,$branchcode,$bookfundid);
+ $sth->execute($bookfundname,$bookfundid,"$branchcode");
# budgets depending on a bookfund must have the same branchcode
# if the bookfund branchcode is set
if (defined $branchcode) {
@@ -381,15 +354,12 @@
=head3 SearchBookFund
-=over 4
@results = SearchBookFund(
$bookfundid,$filter,$filter_bookfundid,
$filter_bookfundname,$filter_branchcode);
this function searchs among the bookfunds corresponding to our filtering rules.
-=back
-
=cut
sub SearchBookFund {
@@ -408,7 +378,7 @@
bookfundgroup,
branchcode
FROM aqbookfund
- WHERE 1 = 1 ";
+ WHERE 1 ";
if ($filter) {
if ($filter_bookfundid) {
@@ -439,14 +409,10 @@
=head3 ModCurrencies
-=over 4
-
&ModCurrencies($currency, $newrate);
Sets the exchange rate for C<$currency> to be C<$newrate>.
-=back
-
=cut
sub ModCurrencies {
@@ -465,28 +431,26 @@
=head3 Countbookfund
-=over 4
-
$number = Countbookfund($bookfundid);
this function count the number of bookfund with id given on input arg.
return :
the result of the SQL query as a number.
-=back
-
=cut
sub Countbookfund {
my $bookfundid = shift;
+ my $branchcode = shift;
my $dbh = C4::Context->dbh;
my $query ="
SELECT COUNT(*)
FROM aqbookfund
WHERE bookfundid = ?
+ AND branchcode = ?
";
my $sth = $dbh->prepare($query);
- $sth->execute($bookfundid);
+ $sth->execute($bookfundid,$branchcode);
return $sth->fetchrow;
}
@@ -495,8 +459,6 @@
=head3 ConvertCurrency
-=over 4
-
$foreignprice = &ConvertCurrency($currency, $localprice);
Converts the price C<$localprice> to foreign currency C<$currency> by
@@ -505,8 +467,6 @@
If no exchange rate is found, C<&ConvertCurrency> assumes the rate is one
to one.
-=back
-
=cut
sub ConvertCurrency {
@@ -520,7 +480,7 @@
my $sth = $dbh->prepare($query);
$sth->execute($currency);
my $cur = ( $sth->fetchrow_array() )[0];
- if ( $cur == 0 ) {
+ unless($cur) {
$cur = 1;
}
return ( $price / $cur );
@@ -530,30 +490,28 @@
=head3 DelBookFund
-=over 4
-
&DelBookFund($bookfundid);
this function delete a bookfund which has $bokfundid as parameter on aqbookfund table and delete the approriate budget.
-=back
-
=cut
sub DelBookFund {
my $bookfundid = shift;
+ my $branchcode=shift;
my $dbh = C4::Context->dbh;
my $query = "
DELETE FROM aqbookfund
WHERE bookfundid=?
+ AND branchcode=?
";
my $sth=$dbh->prepare($query);
- $sth->execute($bookfundid);
+ $sth->execute($bookfundid,$branchcode);
$sth->finish;
$query = "
- DELETE FROM aqbudget where bookfundid=?
+ DELETE FROM aqbudget where bookfundid=? and branchcode=?
";
$sth=$dbh->prepare($query);
- $sth->execute($bookfundid);
+ $sth->execute($bookfundid,$branchcode);
$sth->finish;
}
@@ -563,8 +521,6 @@
__END__
-=back
-
=head1 AUTHOR
Koha Developement team <info at koha.org>
Index: Bookseller.pm
===================================================================
RCS file: /sources/koha/koha/C4/Bookseller.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -b -r1.1 -r1.2
--- Bookseller.pm 27 Jul 2006 13:39:00 -0000 1.1
+++ Bookseller.pm 9 Mar 2007 14:31:47 -0000 1.2
@@ -17,14 +17,14 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Bookseller.pm,v 1.1 2006/07/27 13:39:00 toins Exp $
+# $Id: Bookseller.pm,v 1.2 2007/03/09 14:31:47 tipaul Exp $
use strict;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+$VERSION = do { my @v = '$Revision: 1.2 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
@ISA = qw(Exporter);
@EXPORT = qw(
@@ -50,15 +50,11 @@
=head1 FUNCTIONS
-=over 2
-
=cut
#-------------------------------------------------------------------#
-=head3 GetBookSeller
-
-=over 4
+=head2 GetBookSeller
@results = &GetBookSeller($searchstring);
@@ -68,8 +64,6 @@
C<@results> is an array of references-to-hash, whose keys are the fields of of the
aqbooksellers table in the Koha database.
-=back
-
=cut
sub GetBookSeller {
@@ -93,20 +87,16 @@
#-----------------------------------------------------------------#
-=head3 GetBooksellersWithLateOrders
-
-=over 4
+=head2 GetBooksellersWithLateOrders
%results = &GetBooksellersWithLateOrders;
Searches for suppliers with late orders.
-=back
-
=cut
sub GetBooksellersWithLateOrders {
- my $delay = shift;
+ my ($delay,$branch) = @_;
my $dbh = C4::Context->dbh;
# FIXME NOT quite sure that this operation is valid for DBMs different from Mysql, HOPING so
@@ -147,9 +137,7 @@
#--------------------------------------------------------------------#
-=head3 AddBookseller
-
-=over 4
+=head2 AddBookseller
$id = &AddBookseller($bookseller);
@@ -159,8 +147,6 @@
Returns the ID of the newly-created bookseller.
-=back
-
=cut
sub AddBookseller {
@@ -197,20 +183,18 @@
);
# return the id of this new supplier
- my $query = "
+ $query = "
SELECT max(id)
FROM aqbooksellers
";
- my $sth = $dbh->prepare($query);
+ $sth = $dbh->prepare($query);
$sth->execute;
return scalar($sth->fetchrow);
}
#-----------------------------------------------------------------#
-=head3 ModSupplier
-
-=over 4
+=head2 ModSupplier
&ModSupplier($bookseller);
@@ -223,8 +207,6 @@
book seller with C<&booksellers>, modify what's necessary, then call
C<&ModSupplier> with the result.
-=back
-
=cut
sub ModBookseller {
@@ -260,15 +242,12 @@
$sth->finish;
}
-
END { } # module clean-up code here (global destructor)
1;
__END__
-=back
-
=head1 AUTHOR
Koha Developement team <info at koha.org>
Index: Breeding.pm
===================================================================
RCS file: /sources/koha/koha/C4/Breeding.pm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- Breeding.pm 6 Nov 2006 21:01:43 -0000 1.13
+++ Breeding.pm 9 Mar 2007 14:31:47 -0000 1.14
@@ -19,11 +19,10 @@
use strict;
use C4::Biblio;
-use C4::Search;
+use C4::Koha;
use MARC::File::USMARC;
-use MARC::Record;
-use Encode;
require Exporter;
+
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
@@ -34,6 +33,8 @@
C4::Breeding : script to add a biblio in marc_breeding table.
=head1 SYNOPSIS
+
+ use C4::Scan;
&ImportBreeding($marcrecords,$overwrite_biblio,$filename,$z3950random);
C<$marcrecord> => the MARC::Record
@@ -47,7 +48,10 @@
=head1 DESCRIPTION
-This is for depository of records coming from z3950 or directly imported.
+ ImportBreeding import MARC records in the reservoir (marc_breeding table).
+ the records can be properly encoded or not, we try to reencode them in utf-8 if needed.
+ works perfectly with BNF server, that sends UNIMARC latin1 records. Should work with other servers too.
+ the FixEncoding sub is in Koha.pm, as it's a general usage sub.
=cut
@@ -56,19 +60,14 @@
sub ImportBreeding {
my ($marcrecords,$overwrite_biblio,$filename,$encoding,$z3950random) = @_;
-## use marc:batch send them in one by one
-# my @marcarray = split /\x1D/, $marcrecords;
+ my @marcarray = split /\x1D/, $marcrecords;
my $dbh = C4::Context->dbh;
-my @kohafields;
-my @values;
-my @relations;
-my $sort;
-my @and_or;
-my @results;
-my $count;
- my $searchbreeding = $dbh->prepare("select id from marc_breeding where isbn=? and title=?");
- my $insertsql = $dbh->prepare("insert into marc_breeding (file,isbn,title,author,marc,encoding,z3950random,classification,subclass) values(?,?,?,?,?,?,?,?,?)");
- my $replacesql = $dbh->prepare("update marc_breeding set file=?,isbn=?,title=?,author=?,marc=?,encoding=?,z3950random=?,classification=?,subclass=? where id=?");
+ my $searchisbn = $dbh->prepare("select biblioitemnumber from biblioitems where isbn=?");
+ my $searchissn = $dbh->prepare("select biblioitemnumber from biblioitems where issn=?");
+ my $searchbreeding = $dbh->prepare("select id from marc_breeding
+where isbn=? and title=?");
+ my $insertsql = $dbh->prepare("insert into marc_breeding (file,isbn,title,author,marc,encoding,z3950random) values(?,?,?,?,?,?,?)");
+ my $replacesql = $dbh->prepare("update marc_breeding set file=?,isbn=?,title=?,author=?,marc=?,encoding=?,z3950random=? where id=?");
$encoding = C4::Context->preference("marcflavour") unless $encoding;
# fields used for import results
my $imported=0;
@@ -76,47 +75,39 @@
my $alreadyinfarm = 0;
my $notmarcrecord = 0;
my $breedingid;
-# for (my $i=0;$i<=$#marcarray;$i++) {
- my $marcrecord = MARC::File::USMARC::decode($marcrecords);
- my $marcxml=$marcrecord->as_xml_record($marcrecord);
- $marcxml=Encode::encode('utf8',$marcxml);
+ for (my $i=0;$i<=$#marcarray;$i++) {
+ my $marcrecord = FixEncoding($marcarray[$i]."\x1D");
my @warnings = $marcrecord->warnings();
if (scalar($marcrecord->fields()) == 0) {
$notmarcrecord++;
} else {
- my $xmlhash=XML_xml2hash_onerecord($marcxml);
- my $oldbiblio = XMLmarc2koha_onerecord($dbh,$xmlhash,'biblios');
+ my $oldbiblio = MARCmarc2koha($dbh,$marcrecord,'');
+ my $isbnlength=10;
+ if($oldbiblio->{isbn}){
+ $isbnlength = length($oldbiblio->{isbn});
+ }
# if isbn found and biblio does not exist, add it. If isbn found and biblio exists, overwrite or ignore depending on user choice
# drop every "special" char : spaces, - ...
$oldbiblio->{isbn} =~ s/ |-|\.//g,
- $oldbiblio->{isbn} = substr($oldbiblio->{isbn},0,10);
+ $oldbiblio->{isbn} = substr($oldbiblio->{isbn},0,$isbnlength);
$oldbiblio->{issn} =~ s/ |-|\.//g,
$oldbiblio->{issn} = substr($oldbiblio->{issn},0,10);
# search if biblio exists
my $biblioitemnumber;
- my $facets;
- if ( !$z3950random){
if ($oldbiblio->{isbn}) {
- push @kohafields,"isbn";
- push @values,$oldbiblio->{isbn};
- push @relations,"";
- push @and_or,"";
-
- ($count,$facets, at results)=ZEBRAsearch_kohafields(\@kohafields,\@values,\@relations);
- } else {
- push @kohafields,"issn";
- push @values,$oldbiblio->{issn};
- push @relations,"";
- push @and_or,"";
- $sort="";
- ($count,$facets, at results)=ZEBRAsearch_kohafields(\@kohafields,\@values,\@relations);
+ $searchisbn->execute($oldbiblio->{isbn});
+ ($biblioitemnumber) = $searchisbn->fetchrow;
+ } else {
+ if ($oldbiblio->{issn}) {
+ $searchissn->execute($oldbiblio->{issn});
+ ($biblioitemnumber) = $searchissn->fetchrow;
}
}
- if ($count>0 && !$z3950random) {
+ if ($biblioitemnumber) {
$alreadyindb++;
} else {
# search in breeding farm
-
+# my $breedingid;
if ($oldbiblio->{isbn}) {
$searchbreeding->execute($oldbiblio->{isbn},$oldbiblio->{title});
($breedingid) = $searchbreeding->fetchrow;
@@ -127,28 +118,26 @@
if ($breedingid && $overwrite_biblio eq 0) {
$alreadyinfarm++;
} else {
- my $recoded=MARC::Record->new_from_xml($marcxml,"UTF-8");
- $recoded->encoding('UTF-8');
-
+ my $recoded;
+ $recoded = $marcrecord->as_usmarc();
if ($breedingid && $overwrite_biblio eq 1) {
- $replacesql ->execute($filename,substr($oldbiblio->{isbn}.$oldbiblio->{issn},0,10),$oldbiblio->{title},$oldbiblio->{author},$recoded->as_usmarc,$encoding,$z3950random,$oldbiblio->{classification},$oldbiblio->{subclass},$breedingid);
+ $replacesql ->execute($filename,substr($oldbiblio->{isbn}.$oldbiblio->{issn},0,$isbnlength),$oldbiblio->{title},$oldbiblio->{author},$recoded,$encoding,$z3950random,$breedingid);
} else {
- $insertsql ->execute($filename,substr($oldbiblio->{isbn}.$oldbiblio->{issn},0,10),$oldbiblio->{title},$oldbiblio->{author},$recoded->as_usmarc,$encoding,$z3950random,$oldbiblio->{classification},$oldbiblio->{subclass});
-
+ $insertsql ->execute($filename,substr($oldbiblio->{isbn}.$oldbiblio->{issn},0,$isbnlength),$oldbiblio->{title},$oldbiblio->{author},$recoded,$encoding,$z3950random);
$breedingid=$dbh->{'mysql_insertid'};
}
$imported++;
}
}
}
- #}
+ }
return ($notmarcrecord,$alreadyindb,$alreadyinfarm,$imported,$breedingid);
}
=item BreedingSearch
- ($count, @results) = &BreedingSearch($title,$isbn,$random);
+($count, @results) = &BreedingSearch($title,$isbn,$random);
C<$title> contains the title,
C<$isbn> contains isbn or issn,
C<$random> contains the random seed from a z3950 search.
@@ -166,7 +155,7 @@
my $sth;
my @results;
- $query = "Select id,file,isbn,title,author,classification,subclass from marc_breeding where ";
+ $query = "Select id,file,isbn,title,author from marc_breeding where ";
if ($z3950random) {
$query .= "z3950random = ?";
@bind=($z3950random);
Index: Context.pm
===================================================================
RCS file: /sources/koha/koha/C4/Context.pm,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -b -r1.50 -r1.51
--- Context.pm 6 Nov 2006 21:01:43 -0000 1.50
+++ Context.pm 9 Mar 2007 14:31:47 -0000 1.51
@@ -1,3 +1,4 @@
+package C4::Context;
# Copyright 2002 Katipo Communications
#
# This file is part of Koha.
@@ -15,17 +16,19 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Context.pm,v 1.50 2006/11/06 21:01:43 tgarip1957 Exp $
-package C4::Context;
+# $Id: Context.pm,v 1.51 2007/03/09 14:31:47 tipaul Exp $
use strict;
use DBI;
-use C4::Boolean;
+use ZOOM;
use XML::Simple;
+
+use C4::Boolean;
+
use vars qw($VERSION $AUTOLOAD),
qw($context),
qw(@context_stack);
-$VERSION = do { my @v = '$Revision: 1.50 $' =~ /\d+/g;
+$VERSION = do { my @v = '$Revision: 1.51 $' =~ /\d+/g;
shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
=head1 NAME
@@ -39,7 +42,13 @@
use C4::Context("/path/to/koha.xml");
$config_value = C4::Context->config("config_variable");
+
+ $koha_preference = C4::Context->preference("preference");
+
$db_handle = C4::Context->dbh;
+
+ $Zconn = C4::Context->Zconn;
+
$stopwordhash = C4::Context->stopwords;
=head1 DESCRIPTION
@@ -97,38 +106,46 @@
$context = undef; # Initially, no context is set
@context_stack = (); # Initially, no saved contexts
-# read_config_file
-# Reads the specified Koha config file. Returns a reference-to-hash
-# whose keys are the configuration variables, and whose values are the
-# configuration values (duh).
-# Returns undef in case of error.
-#
-# Revision History:
-# 2004-08-10 A. Tarallo: Added code that checks if a variable is already
-# assigned and prints a message, otherwise create a new entry in the hash to
-# be returned.
-# Also added code that complaints if finds a line that isn't a variable
-# assignmet and skips the line.
-# Added a quick hack that makes the translation between the db_schema
-# and the DBI driver for that schema.
-#
-sub read_config_file
-{
- my $fname = shift; # Config file to read
+=item read_config_file
+
+=over 4
+
+Reads the specified Koha config file.
+
+Returns an object containing the configuration variables. The object's
+structure is a bit complex to the uninitiated ... take a look at the
+koha.xml file as well as the XML::Simple documentation for details. Or,
+here are a few examples that may give you what you need:
+
+The simple elements nested within the <config> element:
+
+ my $pass = $koha->{'config'}->{'pass'};
- my $retval = {}; # Return value: ref-to-hash holding the
- # configuration
+The <listen> elements:
-my $koha = XMLin($fname, keyattr => ['id'],forcearray => ['listen']);
+ my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
+
+The elements nested within the <server> element:
+
+ my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
+
+Returns undef in case of error.
+
+=back
+
+=cut
+sub read_config_file {
+ my $fname = shift; # Config file to read
+ my $retval = {}; # Return value: ref-to-hash holding the configuration
+ my $koha = XMLin($fname, keyattr => ['id'],forcearray => ['listen']);
return $koha;
}
# db_scheme2dbi
# Translates the full text name of a database into de appropiate dbi name
#
-sub db_scheme2dbi
-{
+sub db_scheme2dbi {
my $name = shift;
for ($name) {
@@ -140,8 +157,7 @@
return undef; # Just in case
}
-sub import
-{
+sub import {
my $package = shift;
my $conf_fname = shift; # Config file name
my $context;
@@ -170,8 +186,7 @@
#'
# Revision History:
# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
-sub new
-{
+sub new {
my $class = shift;
my $conf_fname = shift; # Config file to load
my $self = {};
@@ -190,17 +205,13 @@
$self = read_config_file($conf_fname);
$self->{"config_file"} = $conf_fname;
-
-
warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
return undef if !defined($self->{"config"});
$self->{"dbh"} = undef; # Database handle
- $self->{"Zconn"} = undef; # Zebra Connection
- $self->{"Zconnauth"} = undef; # Zebra Connection for updating
+ $self->{"Zconn"} = undef; # Zebra Connections
$self->{"stopwords"} = undef; # stopwords list
$self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
- $self->{"attrfromkohafield"} = undef; # the hash with relations between koha table fields and Bib1-attributes
$self->{"userenv"} = undef; # User env
$self->{"activeuser"} = undef; # current active user
@@ -312,12 +323,6 @@
# Return the value of the requested config variable
return $context->{"config"}->{$var};
}
-=item zebraconfig
-$serverdir=C4::Context->zebraconfig("biblioserver")->{directory};
-
-returns the zebra server specific details for different zebra servers
-similar to C4:Context->config
-=cut
sub zebraconfig
{
@@ -325,9 +330,28 @@
my $var = shift; # The config variable to return
return undef if !defined($context->{"server"});
+ # Presumably $self->{config} might be
+ # undefined if the config file given to &new
+ # didn't exist, and the caller didn't bother
+ # to check the return value.
+
# Return the value of the requested config variable
return $context->{"server"}->{$var};
}
+sub zebraoptions
+{
+ my $self = shift;
+ my $var = shift; # The config variable to return
+
+ return undef if !defined($context->{"serverinfo"});
+ # Presumably $self->{config} might be
+ # undefined if the config file given to &new
+ # didn't exist, and the caller didn't bother
+ # to check the return value.
+
+ # Return the value of the requested config variable
+ return $context->{"serverinfo"}->{$var};
+}
=item preference
$sys_preference = C4::Context->preference("some_variable");
@@ -348,6 +372,7 @@
my $var = shift; # The system preference to return
my $retval; # Return value
my $dbh = C4::Context->dbh; # Database handle
+ if ($dbh){
my $sth; # Database query handle
# Look up systempreferences.variable==$var
@@ -358,6 +383,9 @@
LIMIT 1
EOT
return $retval;
+ } else {
+ return 0
+ }
}
sub boolean_preference ($) {
@@ -388,84 +416,112 @@
=item Zconn
$Zconn = C4::Context->Zconn
-$Zconnauth = C4::Context->Zconnauth
+
Returns a connection to the Zebra database for the current
context. If no connection has yet been made, this method
creates one and connects.
+C<$self>
+
+C<$server> one of the servers defined in the koha.xml file
+
+C<$async> whether this is a asynchronous connection
+
+C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
+
+
=cut
sub Zconn {
- my $self = shift;
-my $server=shift;
-my $syntax=shift;
- my $Zconn;
- $context->{"Zconn"} = &new_Zconn($server,$syntax);
- return $context->{"Zconn"};
-
+ my $self=shift;
+ my $server=shift;
+ my $async=shift;
+ my $auth=shift;
+ my $piggyback=shift;
+ my $syntax=shift;
+ if ( defined($context->{"Zconn"}->{$server}) ) {
+ return $context->{"Zconn"}->{$server};
+
+ # No connection object or it died. Create one.
+ }else {
+ $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
+ return $context->{"Zconn"}->{$server};
+ }
}
-sub Zconnauth {
- my $self = shift;
-my $server=shift;
-my $syntax=shift;
- my $Zconnauth;
-##We destroy each connection made so create a new one
- $context->{"Zconnauth"} = &new_Zconnauth($server,$syntax);
- return $context->{"Zconnauth"};
+=item _new_Zconn
-}
+$context->{"Zconn"} = &_new_Zconn($server,$async);
+Internal function. Creates a new database connection from the data given in the current context and returns it.
+C<$server> one of the servers defined in the koha.xml file
-=item new_Zconn
+C<$async> whether this is a asynchronous connection
-Internal helper function. creates a new database connection from
-the data given in the current context and returns it.
+C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
=cut
-sub new_Zconn {
-use ZOOM;
-my $server=shift;
-my $syntax=shift;
-$syntax="xml" unless $syntax;
-my $Zconn;
-my ($tcp,$host,$port)=split /:/,$context->{"listen"}->{$server}->{"content"};
-my $o = new ZOOM::Options();
-$o->option(async => 1);
-$o->option(preferredRecordSyntax => $syntax); ## in case we use MARC
-$o->option(databaseName=>$context->{"config"}->{$server});
-
-my $o2= new ZOOM::Options();
+sub _new_Zconn {
+ my ($server,$async,$auth,$piggyback,$syntax) = @_;
- $Zconn=create ZOOM::Connection($o);
- $Zconn->connect($context->{"config"}->{"hostname"},$port);
+ my $tried=0; # first attempt
+ my $Zconn; # connection object
+ $server = "biblioserver" unless $server;
+ $syntax = "usmarc" unless $syntax;
+
+ my $host = $context->{'listen'}->{$server}->{'content'};
+ my $user = $context->{"serverinfo"}->{$server}->{"user"};
+ my $servername = $context->{"config"}->{$server};
+ my $password = $context->{"serverinfo"}->{$server}->{"password"};
+ warn "server:$server servername :$servername host:$host";
+ retry:
+ eval {
+ # set options
+ my $o = new ZOOM::Options();
+ $o->option(async => 1) if $async;
+ $o->option(count => $piggyback) if $piggyback;
+ $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
+ $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
+ $o->option(preferredRecordSyntax => $syntax);
+ $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
+ $o->option(user=>$user) if $auth;
+ $o->option(password=>$password) if $auth;
+ $o->option(databaseName => ($servername?$servername:"biblios"));
+
+ # create a new connection object
+ $Zconn= create ZOOM::Connection($o);
+
+ # forge to server
+ $Zconn->connect($host, 0);
+
+ # check for errors and warn
+ if ($Zconn->errcode() !=0) {
+ warn "something wrong with the connection: ". $Zconn->errmsg();
+ }
+ };
+# if ($@) {
+# # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
+# # Also, I'm skeptical about whether it's the best approach
+# warn "problem with Zebra";
+# if ( C4::Context->preference("ManageZebra") ) {
+# if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
+# $tried=1;
+# warn "trying to restart Zebra";
+# my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
+# goto "retry";
+# } else {
+# warn "Error ", $@->code(), ": ", $@->message(), "\n";
+# $Zconn="error";
+# return $Zconn;
+# }
+# }
+# }
return $Zconn;
}
-## Zebra handler with write permission
-sub new_Zconnauth {
-use ZOOM;
-my $server=shift;
-my $syntax=shift;
-$syntax="xml" unless $syntax;
-my $Zconnauth;
-my ($tcp,$host,$port)=split /:/,$context->{"listen"}->{$server}->{"content"};
-my $o = new ZOOM::Options();
-#$o->option(async => 1);
-$o->option(preferredRecordSyntax => $syntax);
-$o->option(user=>$context->{"config"}->{"zebrauser"});
-$o->option(password=>$context->{"config"}->{"zebrapass"});
-$o->option(databaseName=>$context->{"config"}->{$server});
- $o->option(charset=>"UTF8");
- $Zconnauth=create ZOOM::Connection($o);
-$Zconnauth->connect($context->config("hostname"),$port);
-return $Zconnauth;
-}
-
-
# _new_dbh
# Internal helper function (not a method!). This creates a new
# database connection from the data given in the current context, and
@@ -487,11 +543,8 @@
my $dbh= DBI->connect("DBI:$db_driver:$db_name:$db_host",
$db_user, $db_passwd);
# Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
- ###DBD::Mysql 3.0.7 has an intermittent bug for dbh->do so change to dbh->prepare
- my $sth=$dbh->prepare("set NAMES 'utf8'");
- $sth->execute();
- $sth->finish;
-
+ # this is better than modifying my.cnf (and forcing all communications to be in utf8)
+ $dbh->do("set NAMES 'utf8'") if ($dbh);
return $dbh;
}
@@ -631,50 +684,22 @@
return $context->{"marcfromkohafield"};
}
-
# _new_marcfromkohafield
-# Internal helper function (not a method!).
+# Internal helper function (not a method!). This creates a new
+# hash with stopwords
sub _new_marcfromkohafield
{
my $dbh = C4::Context->dbh;
my $marcfromkohafield;
- my $sth = $dbh->prepare("select kohafield,tagfield,tagsubfield,recordtype from koha_attr where tagfield is not null ");
+ my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
$sth->execute;
- while (my ($kohafield,$tagfield,$tagsubfield,$recordtype) = $sth->fetchrow) {
+ while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
my $retval = {};
- $marcfromkohafield->{$recordtype}->{$kohafield} = [$tagfield,$tagsubfield];
+ $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
}
-
return $marcfromkohafield;
}
-
-#item attrfromkohafield
-#To use as a hash of koha to z3950 attributes
-sub _new_attrfromkohafield
-{
- my $dbh = C4::Context->dbh;
- my $attrfromkohafield;
- my $sth2 = $dbh->prepare("select kohafield,attr from koha_attr" );
- $sth2->execute;
- while (my ($kohafield,$attr) = $sth2->fetchrow) {
- my $retval = {};
- $attrfromkohafield->{$kohafield} = $attr;
- }
- return $attrfromkohafield;
-}
-sub attrfromkohafield
-{
- my $retval = {};
-
- # If the hash already exists, return it.
- return $context->{"attrfromkohafield"} if defined($context->{"attrfromkohafield"});
-
- # No hash. Create one.
- $context->{"attrfromkohafield"} = &_new_attrfromkohafield();
-
- return $context->{"attrfromkohafield"};
-}
=item stopwords
$dbh = C4::Context->stopwords;
@@ -735,8 +760,20 @@
{
my $var = $context->{"activeuser"};
return $context->{"userenv"}->{$var} if (defined $context->{"userenv"}->{$var});
+ # insecure=1 management
+ if ($context->{"dbh"} && $context->preference('insecure')) {
+ my %insecure;
+ $insecure{flags} = '16382';
+ $insecure{branchname} ='Insecure',
+ $insecure{number} ='0';
+ $insecure{cardnumber} ='0';
+ $insecure{id} = 'insecure';
+ $insecure{branch} = 'INS';
+ $insecure{emailaddress} = 'test at mode.insecure.com';
+ return \%insecure;
+ } else {
return 0;
- warn "NO CONTEXT for $var";
+ }
}
=item set_userenv
@@ -751,22 +788,22 @@
set_userenv is called in Auth.pm
=cut
+
#'
sub set_userenv{
- my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress,$branchprinter)= @_;
+ my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress)= @_;
my $var=$context->{"activeuser"};
my $cell = {
"number" => $usernum,
"id" => $userid,
"cardnumber" => $usercnum,
-# "firstname" => $userfirstname,
-# "surname" => $usersurname,
+ "firstname" => $userfirstname,
+ "surname" => $usersurname,
#possibly a law problem
"branch" => $userbranch,
"branchname" => $branchname,
"flags" => $userflags,
"emailaddress" => $emailaddress,
- "branchprinter" => $branchprinter,
};
$context->{userenv}->{$var} = $cell;
return $cell;
@@ -800,6 +837,7 @@
Destroys the hash for activeuser user environment variables.
=cut
+
#'
sub _unset_userenv
@@ -827,57 +865,112 @@
=head1 SEE ALSO
-DBI(3)
-
-=head1 AUTHOR
+=head1 AUTHORS
Andrew Arensburger <arensb at ooblick dot com>
+Joshua Ferraro <jmf at liblime dot com>
+
=cut
+
# $Log: Context.pm,v $
-# Revision 1.50 2006/11/06 21:01:43 tgarip1957
-# Bug fixing and complete removal of Date::Manip
+# Revision 1.51 2007/03/09 14:31:47 tipaul
+# rel_3_0 moved to HEAD
+#
+# Revision 1.43.2.10 2007/02/09 17:17:56 hdl
+# Managing a little better database absence.
+# (preventing from BIG 550)
+#
+# Revision 1.43.2.9 2006/12/20 16:50:48 tipaul
+# improving "insecure" management
+#
+# WARNING KADOS :
+# you told me that you had some libraries with insecure=ON (behind a firewall).
+# In this commit, I created a "fake" user when insecure=ON. It has a fake branch. You may find better to have the 1st branch in branch table instead of a fake one.
+#
+# Revision 1.43.2.8 2006/12/19 16:48:16 alaurin
+# reident programs, and adding branchcode value in reserves2
+#
+# Revision 1.43.2.7 2006/12/06 21:55:38 hdl
+# Adding zebraoptions for servers to get serverinfos in Context.pm
+# Using this function in rebuild_zebra.pl
+#
+# Revision 1.43.2.6 2006/11/24 21:18:31 kados
+# very minor changes, no functional ones, just comments, etc.
+#
+# Revision 1.43.2.5 2006/10/30 13:24:16 toins
+# fix some minor POD error.
+#
+# Revision 1.43.2.4 2006/10/12 21:42:49 hdl
+# Managing multiple zebra connections
+#
+# Revision 1.43.2.3 2006/10/11 14:27:26 tipaul
+# removing a warning
+#
+# Revision 1.43.2.2 2006/10/10 15:28:16 hdl
+# BUG FIXING : using database name in Zconn if defined and not hard coded value
+#
+# Revision 1.43.2.1 2006/10/06 13:47:28 toins
+# Synch with dev_week.
+# /!\ WARNING :: Please now use the new version of koha.xml.
+#
+# Revision 1.18.2.5.2.14 2006/09/24 15:24:06 kados
+# remove Zebraauth routine, fold the functionality into Zconn
+# Zconn can now take several arguments ... this will probably
+# change soon as I'm not completely happy with the readability
+# of the current format ... see the POD for details.
+#
+# cleaning up Biblio.pm, removing unnecessary routines.
#
-# Revision 1.49 2006/10/20 01:20:56 tgarip1957
-# A new Date.pm to use for all date calculations. Mysql date calculations removed from Circ2.pm, all modules free of DateManip, a new get_today function to call in allscripts, and some bug cleaning in authorities.pm
+# DeleteBiblio - used to delete a biblio from zebra and koha tables
+# -- checks to make sure there are no existing issues
+# -- saves backups of biblio,biblioitems,items in deleted* tables
+# -- does commit operation
#
-# Revision 1.48 2006/10/01 21:48:54 tgarip1957
-# Field weighting applied to ranked searches. A new facets table in mysql db
+# getRecord - used to retrieve one record from zebra in piggyback mode using biblionumber
+# brought back z3950_extended_services routine
#
-# Revision 1.47 2006/09/27 19:53:52 tgarip1957
-# Finalizing main components. All koha modules are now working with the new XML API
+# Lots of modifications to Context.pm, you can now store user and pass info for
+# multiple servers (for federated searching) using the <serverinfo> element.
+# I'll commit my koha.xml to demonstrate this or you can refer to the POD in
+# Context.pm (which I also expanded on).
#
-# Revision 1.46 2006/09/06 16:21:03 tgarip1957
-# Clean up before final commits
+# Revision 1.18.2.5.2.13 2006/08/10 02:10:21 kados
+# Turned warnings on, and running a search turned up lots of warnings.
+# Cleaned up those ...
#
-# Revision 1.43 2006/08/10 12:49:37 toins
-# sync with dev_week.
+# removed getitemtypes from Koha.pm (one in Search.pm looks newer)
+# removed itemcount from Biblio.pm
#
-# Revision 1.42 2006/07/04 14:36:51 toins
-# Head & rel_2_2 merged
+# made some local subs local with a _ prefix (as they were redefined
+# elsewhere)
#
-# Revision 1.41 2006/05/20 14:36:09 tgarip1957
-# Typo error. Missing '>'
+# Add two new search subs to Search.pm the start of a new search API
+# that's a bit more scalable
#
-# Revision 1.40 2006/05/20 14:28:02 tgarip1957
-# Adding support to read zebra database name from config files
+# Revision 1.18.2.5.2.10 2006/07/21 17:50:51 kados
+# moving the *.properties files to intranetdir/etc dir
#
-# Revision 1.39 2006/05/19 09:52:54 alaurin
-# committing new feature ip and printer management
-# adding two fields in branches table (branchip,branchprinter)
+# Revision 1.18.2.5.2.9 2006/07/17 08:05:20 tipaul
+# there was a hardcoded link to /koha/etc/ I replaced it with intranetdir config value
#
-# branchip : if the library enter an ip or ip range any librarian that connect from computer in this ip range will be temporarly affected to the corresponding branch .
+# Revision 1.18.2.5.2.8 2006/07/11 12:20:37 kados
+# adding ccl and cql files ... Tumer, if you want to fit these into the
+# config file by all means do.
#
-# branchprinter : the library can select a default printer for a branch
+# Revision 1.18.2.5.2.7 2006/06/04 22:50:33 tgarip1957
+# We do not hard code cql2rpn conversion file in context.pm our koha.xml configuration file already describes the path for this file.
+# At cql searching we use method CQL not CQL2RPN as the cql2rpn conversion file is defined at server level
#
-# Revision 1.38 2006/05/14 00:22:31 tgarip1957
-# Adding support for getting details of different zebra servers
+# Revision 1.18.2.5.2.6 2006/06/02 23:11:24 kados
+# Committing my working dev_week. It's been tested only with
+# searching, and there's quite a lot of config stuff to set up
+# beforehand. As things get closer to a release, we'll be making
+# some scripts to do it for us
#
-# Revision 1.37 2006/05/13 19:51:39 tgarip1957
-# Now reads koha.xml rather than koha.conf.
-# koha.xml contains both the koha configuration and zebraserver configuration.
-# Zebra connection is modified to allow connection to authority zebra as well.
-# It will break head if koha.conf is not replaced with koha.xml
+# Revision 1.18.2.5.2.5 2006/05/28 18:49:12 tgarip1957
+# This is an unusual commit. The main purpose is a working model of Zebra on a modified rel2_2.
+# Any questions regarding these commits should be asked to Joshua Ferraro unless you are Joshua whom I'll report to
#
# Revision 1.36 2006/05/09 13:28:08 tipaul
# adding the branchname and the librarian name in every page :
Index: Date.pm
===================================================================
RCS file: /sources/koha/koha/C4/Date.pm,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -b -r1.24 -r1.25
--- Date.pm 15 Nov 2006 01:36:00 -0000 1.24
+++ Date.pm 9 Mar 2007 14:31:47 -0000 1.25
@@ -1,38 +1,16 @@
-#!/usr/bin/perl
-## written by T Garip 2006-10-10 tgarip at neu.edu.tr
-# Copyright 2000-2002 Katipo Communications
-#
-# 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 2 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, write to the Free Software Foundation, Inc., 59 Temple Place,
-# Suite 330, Boston, MA 02111-1307 USA
-
-# $Id: Date.pm,v 1.24 2006/11/15 01:36:00 tgarip1957 Exp $
+#!/usr/bin/perl -w
package C4::Date;
use strict;
use C4::Context;
-use DateTime;
-use DateTime::Format::ISO8601;
-use DateTime::Format::Strptime;
-use DateTime::Format::Duration;
-use POSIX qw(ceil floor);
+use Date::Calc qw(Parse_Date Decode_Date_EU Decode_Date_US Time_to_Date check_date);
+
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-$VERSION = do { my @v = '$Revision: 1.24 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+$VERSION = 0.01;
@ISA = qw(Exporter);
@@ -40,177 +18,138 @@
&display_date_format
&format_date
&format_date_in_iso
- &get_date_format_string_for_DHTMLcalendar
- &DATE_diff &DATE_Add
-&get_today &DATE_Add_Duration &DATE_obj &get_duration
-&DATE_subtract
);
-sub get_date_format {
+sub get_date_format
+{
#Get the database handle
my $dbh = C4::Context->dbh;
return C4::Context->preference('dateformat');
}
-sub display_date_format {
+sub display_date_format
+{
my $dateformat = get_date_format();
- if ( $dateformat eq "us" ) {
+ if ( $dateformat eq "us" )
+ {
return "mm/dd/yyyy";
}
- elsif ( $dateformat eq "metric" ) {
+ elsif ( $dateformat eq "metric" )
+ {
return "dd/mm/yyyy";
}
- elsif ( $dateformat eq "iso" ) {
+ elsif ( $dateformat eq "iso" )
+ {
return "yyyy-mm-dd";
}
- else {
- return
-"Invalid date format: $dateformat. Please change in system preferences";
+ else
+ {
+ return "Invalid date format: $dateformat. Please change in system preferences";
}
}
-sub get_date_format_string_for_DHTMLcalendar {
- my $dateformat = get_date_format();
-
- if ( $dateformat eq 'us' ) {
- return '%m/%d/%Y';
- }
- elsif ( $dateformat eq 'metric' ) {
- return '%d/%m/%Y';
- }
- elsif ( $dateformat eq "iso" ) {
- return '%Y-%m-%d';
- }
- else {
- return 'Invalid date format: '
- . $dateformat . '.'
- . ' Please change in system preferences';
- }
-}
-sub format_date {
+sub format_date
+{
my $olddate = shift;
my $newdate;
- if ( !$olddate || $olddate eq "0000-00-00" ) {
+
+ if ( ! $olddate )
+ {
return "";
}
- $olddate=~s/-//g;
- my $olddate=substr($olddate,0,8);
- my $dateformat = get_date_format();
-eval{$newdate =DateTime::Format::ISO8601->parse_datetime($olddate);};
-if ($@ || !$newdate){
-##MARC21 tag 008 has this format YYMMDD
-my $parser = DateTime::Format::Strptime->new( pattern => '%y%m%d' );
- $newdate =$parser->parse_datetime($olddate);
-}
-if (!$newdate){
-return ""; #### some script call format_date more than once --FIX scripts
-}
-
- if ( $dateformat eq "us" ) {
- return $newdate->mdy('/');
+# warn $olddate;
+# $olddate=~s#/|\.|-##g;
+ my ($year,$month,$day)=Parse_Date($olddate);
+ ($year,$month,$day)=split /-|\/|\.|:/,$olddate unless ($year && $month);
+# warn "$olddate annee $year mois $month jour $day";
+ if ($year>0 && $month>0){
+ my $dateformat = get_date_format();
+ $dateformat="metric" if (index(":",$olddate)>0);
+ if ( $dateformat eq "us" )
+ {
+ $newdate = sprintf("%02d/%02d/%04d",$month,$day,$year);
}
- elsif ( $dateformat eq "metric" ) {
- return $newdate->dmy('/');
+ elsif ( $dateformat eq "metric" )
+ {
+ $newdate = sprintf("%02d/%02d/%04d",$day,$month,$year);
}
- elsif ( $dateformat eq "iso" ) {
- return $newdate->ymd;
+ elsif ( $dateformat eq "iso" )
+ {
+ # Date_Init("DateFormat=iso");
+ $newdate = sprintf("%04d-%02d-%02d",$year,$month,$day);
}
- else {
- return
-"Invalid date format: $dateformat. Please change in system preferences";
+ else
+ {
+ return "Invalid date format: $dateformat. Please change in system preferences";
}
-
+# warn "newdate :$newdate";
+ }
+ return $newdate;
}
-sub format_date_in_iso {
+sub format_date_in_iso
+{
my $olddate = shift;
my $newdate;
- my $parser;
- if ( !$olddate || $olddate eq "0000-00-00" ) {
+
+ if ( ! $olddate )
+ {
return "";
}
-
-$parser = DateTime::Format::Strptime->new( pattern => '%d/%m/%Y' );
- $newdate =$parser->parse_datetime($olddate);
-if (!$newdate){
-$parser = DateTime::Format::Strptime->new( pattern => '%m/%d/%Y' );
-$newdate =$parser->parse_datetime($olddate);
-}
-if (!$newdate){
- $parser = DateTime::Format::Strptime->new( pattern => '%Y-%m-%d' );
-$newdate =$parser->parse_datetime($olddate);
-}
- if (!$newdate){
- $parser = DateTime::Format::Strptime->new( pattern => '%y-%m-%d' );
-$newdate =$parser->parse_datetime($olddate);
-}
-
- return $newdate->ymd if $newdate;
-}
-sub DATE_diff {
-## returns 1 if date1>date2 0 if date1==date2 -1 if date1<date2
-my ($date1,$date2)=@_;
-my $dt1=DateTime::Format::ISO8601->parse_datetime($date1);
-my $dt2=DateTime::Format::ISO8601->parse_datetime($date2);
-my $diff=DateTime->compare( $dt1, $dt2 );
-return $diff;
-}
-sub DATE_Add {
-## $amount in days
-my ($date,$amount)=@_;
-my $dt1=DateTime::Format::ISO8601->parse_datetime($date);
-$dt1->add( days=>$amount );
-return $dt1->ymd;
-}
-sub DATE_Add_Duration {
-## Similar as above but uses Duration object as amount --used heavily in serials
-my ($date,$amount)=@_;
-my $dt1=DateTime::Format::ISO8601->parse_datetime($date);
-$dt1->add_duration($amount) ;
-return $dt1->ymd;
-}
-sub get_today{
-my $dt=DateTime->today;
-return $dt->ymd;
-}
-
-sub DATE_obj{
-# only send iso dates to this
-my $date=shift;
- my $parser = DateTime::Format::Strptime->new( pattern => '%Y-%m-%d' );
- my $newdate =$parser->parse_datetime($date);
-return $newdate;
-}
-sub get_duration{
-my $period=shift;
-
-my $parse;
-if ($period=~/ays/){
-$parse="\%e days";
-}elsif ($period=~/week/){
-$parse="\%W weeks";
-}elsif ($period=~/year/){
-$parse="\%Y years";
-}elsif ($period=~/onth/){
-$parse="\%m months";
+ if (check_whether_iso($olddate)){
+ return $olddate;
+ } else {
+ my $dateformat = get_date_format();
+ my ($year,$month,$day);
+ my @date;
+ my $tmpolddate=$olddate;
+ $tmpolddate=~s#/|\.|-|\\##g;
+ $dateformat="metric" if (index(":",$olddate)>0);
+ if ( $dateformat eq "us" )
+ {
+ ($month,$day,$year)=split /-|\/|\.|:/,$olddate unless ($year && $month);
+ if ($month>0 && $day >0){
+ @date = Decode_Date_US($tmpolddate);
+ } else {
+ @date=($year, $month,$day)
+ }
+ }
+ elsif ( $dateformat eq "metric" )
+ {
+ ($day,$month,$year)=split /-|\/|\.|:/,$olddate unless ($year && $month);
+ if ($month>0 && $day >0){
+ @date = Decode_Date_EU($tmpolddate);
+ } else {
+ @date=($year, $month,$day)
+ }
+ }
+ elsif ( $dateformat eq "iso" )
+ {
+ ($year,$month,$day)=split /-|\/|\.|:/,$olddate unless ($year && $month);
+ if ($month>0 && $day >0){
+ @date=($year, $month,$day) if (check_date($year,$month,$day));
+ } else {
+ @date=($year, $month,$day)
+ }
+ }
+ else
+ {
+ return "9999-99-99";
+ }
+ $newdate = sprintf("%04d-%02d-%02d",$date[0],$date[1],$date[2]);
+ return $newdate;
+ }
}
-my $parser=DateTime::Format::Duration->new(pattern => $parse );
- my $duration=$parser->parse_duration($period);
-
-return $duration;
-
-}
-sub DATE_subtract{
-my ($date1,$date2)=@_;
-my $dt1=DateTime::Format::ISO8601->parse_datetime($date1);
-my $dt2=DateTime::Format::ISO8601->parse_datetime($date2);
-my $dur=$dt2->subtract_datetime_absolute($dt1);## in seconds
-my $days=$dur->seconds/(60*60*24);
-return floor($days);
+sub check_whether_iso
+{
+ my $olddate = shift;
+ my @olddate= split /\-/,$olddate ;
+ return 1 if (length($olddate[0])==4 && length($olddate[1])<=2 && length($olddate[2])<=2);
+ return 0;
}
1;
Index: Input.pm
===================================================================
RCS file: /sources/koha/koha/C4/Input.pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -b -r1.21 -r1.22
--- Input.pm 25 Aug 2006 21:07:08 -0000 1.21
+++ Input.pm 9 Mar 2007 14:31:47 -0000 1.22
@@ -21,6 +21,7 @@
use strict;
require Exporter;
use C4::Context;
+use CGI;
use vars qw($VERSION @ISA @EXPORT);
@@ -190,11 +191,13 @@
if ($sth->rows>0){
my @values;
my %labels;
- for (my $i =0;$i<=$sth->rows;$i++){
+
+ for (my $i =0;$i<$sth->rows;$i++){
my $results = $sth->fetchrow_hashref;
push @values, $results->{authorised_value};
$labels{$results->{authorised_value}}=$results->{lib};
}
+ unshift(@values,"");
$CGISort= CGI::scrolling_list(
-name => $input_name,
-values => \@values,
Index: Koha.pm
===================================================================
RCS file: /sources/koha/koha/C4/Koha.pm,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -b -r1.47 -r1.48
--- Koha.pm 6 Nov 2006 21:01:43 -0000 1.47
+++ Koha.pm 9 Mar 2007 14:31:47 -0000 1.48
@@ -17,16 +17,15 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Koha.pm,v 1.47 2006/11/06 21:01:43 tgarip1957 Exp $
+# $Id: Koha.pm,v 1.48 2007/03/09 14:31:47 tipaul Exp $
use strict;
require Exporter;
use C4::Context;
-use C4::Biblio;
-use CGI;
+use C4::Output;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = do { my @v = '$Revision: 1.47 $' =~ /\d+/g; shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+$VERSION = do { my @v = '$Revision: 1.48 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -49,204 +48,119 @@
@ISA = qw(Exporter);
@EXPORT = qw(
+ &slashifyDate
+ &DisplayISBN
&subfield_is_koha_internal_p
- &GetBranches &getbranch &getbranchdetail
- &getprinters &getprinter
- &GetItemTypes &getitemtypeinfo &ItemType
- get_itemtypeinfos_of
+ &GetPrinters &GetPrinter
+ &GetItemTypes &getitemtypeinfo
+ &GetCcodes
+ &GetAuthItemlost
+ &GetAuthItembinding
+ &get_itemtypeinfos_of
&getframeworks &getframeworkinfo
&getauthtypes &getauthtype
- &getallthemes &getalllanguages
- &GetallBranches &getletters
- &getbranchname
- getnbpages
- getitemtypeimagedir
- getitemtypeimagesrc
- getitemtypeimagesrcfromurl
- &getcities
- &getroadtypes
- get_branchinfos_of
- get_notforloan_label_of
- get_infos_of
+ &getallthemes
&getFacets
-
- $DEBUG);
-
-use vars qw();
+ &displaySortby
+ &displayIndexes
+ &displaySubtypesLimit
+ &displayLimitTypes
+ &displayServers
+ &getnbpages
+ &getitemtypeimagesrcfromurl
+ &get_infos_of
+ &get_notforloan_label_of
+ &GetDepartements
+ &GetDepartementLib
+ &getitemtypeimagedir
+ &getitemtypeimagesrc
+ &GetAuthorisedValues
+ &FixEncoding
+ &GetKohaAuthorisedValues
+ $DEBUG
+ );
my $DEBUG = 0;
-# FIXME.. this should be moved to a MARC-specific module
-sub subfield_is_koha_internal_p ($) {
- my($subfield) = @_;
-
- # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
- # But real MARC subfields are always single-character
- # so it really is safer just to check the length
-
- return length $subfield != 1;
-}
-
-=head2 GetBranches
-
- $branches = &GetBranches();
- returns informations about branches.
- Create a branch selector with the following code
- Is branchIndependant sensitive
- When IndependantBranches is set AND user is not superlibrarian, displays only user's branch
-
-=head3 in PERL SCRIPT
-
-my $branches = GetBranches;
-my @branchloop;
-foreach my $thisbranch (sort keys %$branches) {
- my $selected = 1 if $thisbranch eq $branch;
- my %row =(value => $thisbranch,
- selected => $selected,
- branchname => $branches->{$thisbranch}->{'branchname'},
- );
- push @branchloop, \%row;
-}
+=head2 slashifyDate
+ $slash_date = &slashifyDate($dash_date);
-=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>
+Takes a string of the form "DD-MM-YYYY" (or anything separated by
+dashes), converts it to the form "YYYY/MM/DD", and returns the result.
=cut
-sub GetBranches {
-# returns a reference to a hash of references to branches...
- my ($type) = @_;
- my %branches;
- my $branch;
- my $dbh = C4::Context->dbh;
- my $sth;
- if (C4::Context->preference("IndependantBranches") && (C4::Context->userenv->{flags}!=1)){
- my $strsth ="Select * from branches ";
- $strsth.= " WHERE branchcode = ".$dbh->quote(C4::Context->userenv->{branch});
- $strsth.= " order by branchname";
- $sth=$dbh->prepare($strsth);
- } else {
- $sth = $dbh->prepare("Select * from branches order by branchname");
- }
- $sth->execute;
- while ($branch=$sth->fetchrow_hashref) {
- my $nsth = $dbh->prepare("select categorycode from branchrelations where branchcode = ?");
- if ($type){
- $nsth = $dbh->prepare("select categorycode from branchrelations where branchcode = ? and categorycode = ?");
- $nsth->execute($branch->{'branchcode'},$type);
- } else {
- $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;
-}
- return (\%branches);
-}
-
-sub getbranchname {
- my ($branchcode)=@_;
- my $dbh = C4::Context->dbh;
- my $sth;
- $sth = $dbh->prepare("Select branchname from branches where branchcode=?");
- $sth->execute($branchcode);
- my $branchname = $sth->fetchrow_array;
- $sth->finish;
+sub slashifyDate {
- return($branchname);
+ # accepts a date of the form xx-xx-xx[xx] and returns it in the
+ # form xx/xx/xx[xx]
+ my @dateOut = split( '-', shift );
+ return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
}
-=head2 getallbranches
- @branches = &GetallBranches();
- returns informations about ALL branches.
- Create a branch selector with the following code
- IndependantBranches Insensitive...
+=head2 DisplayISBN
+my $string = DisplayISBN( $isbn );
=cut
-
-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) {
- push @branches,$branch;
+sub DisplayISBN {
+ my ($isbn) = @_;
+ my $seg1;
+ if ( substr( $isbn, 0, 1 ) <= 7 ) {
+ $seg1 = substr( $isbn, 0, 1 );
}
- return (@branches);
-}
-
-=head2 getletters
-
- $letters = &getletters($category);
- returns informations about letters.
- if needed, $category filters for letters given category
- Create a letter selector with the following code
-
-=head3 in PERL SCRIPT
+ elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
+ $seg1 = substr( $isbn, 0, 2 );
+ }
+ elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
+ $seg1 = substr( $isbn, 0, 3 );
+ }
+ elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
+ $seg1 = substr( $isbn, 0, 4 );
+ }
+ else {
+ $seg1 = substr( $isbn, 0, 5 );
+ }
+ my $x = substr( $isbn, length($seg1) );
+ my $seg2;
+ if ( substr( $x, 0, 2 ) <= 19 ) {
-my $letters = getletters($cat);
-my @letterloop;
-foreach my $thisletter (keys %$letters) {
- my $selected = 1 if $thisletter eq $letter;
- my %row =(value => $thisletter,
- selected => $selected,
- lettername => $letters->{$thisletter},
- );
- push @letterloop, \%row;
+ # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
+ $seg2 = substr( $x, 0, 2 );
+ }
+ elsif ( substr( $x, 0, 3 ) <= 699 ) {
+ $seg2 = substr( $x, 0, 3 );
+ }
+ elsif ( substr( $x, 0, 4 ) <= 8399 ) {
+ $seg2 = substr( $x, 0, 4 );
+ }
+ elsif ( substr( $x, 0, 5 ) <= 89999 ) {
+ $seg2 = substr( $x, 0, 5 );
+ }
+ elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
+ $seg2 = substr( $x, 0, 6 );
+ }
+ else {
+ $seg2 = substr( $x, 0, 7 );
+ }
+ my $seg3 = substr( $x, length($seg2) );
+ $seg3 = substr( $seg3, 0, length($seg3) - 1 );
+ my $seg4 = substr( $x, -1, 1 );
+ return "$seg1-$seg2-$seg3-$seg4";
}
+# FIXME.. this should be moved to a MARC-specific module
+sub subfield_is_koha_internal_p ($) {
+ my ($subfield) = @_;
-=head3 in TEMPLATE
- <select name="letter">
- <option value="">Default</option>
- <!-- TMPL_LOOP name="letterloop" -->
- <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="lettername" --></option>
- <!-- /TMPL_LOOP -->
- </select>
-
-=cut
+ # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
+ # But real MARC subfields are always single-character
+ # so it really is safer just to check the length
-sub getletters {
-# returns a reference to a hash of references to ALL letters...
- my $cat =@_;
- my %letters;
- my $dbh = C4::Context->dbh;
- my $sth;
- if ($cat ne ""){
- $sth = $dbh->prepare("Select * from letter where module = \'".$cat."\' order by name");
- } else {
- $sth = $dbh->prepare("Select * from letter order by name");
- }
- $sth->execute;
- my $count;
- while (my $letter=$sth->fetchrow_hashref) {
- $letters{$letter->{'code'}}=$letter->{'name'};
- $count++;
- }
- return ($count,\%letters);
+ return length $subfield != 1;
}
=head2 GetItemTypes
@@ -288,22 +202,22 @@
=cut
sub GetItemTypes {
-# returns a reference to a hash of references to branches...
+
+ # returns a reference to a hash of references to branches...
my %itemtypes;
my $dbh = C4::Context->dbh;
my $query = qq|
SELECT *
FROM itemtypes
|;
- my $sth=$dbh->prepare($query);
+ my $sth = $dbh->prepare($query);
$sth->execute;
- while (my $IT=$sth->fetchrow_hashref) {
- $itemtypes{$IT->{'itemtype'}}=$IT;
+ while ( my $IT = $sth->fetchrow_hashref ) {
+ $itemtypes{ $IT->{'itemtype'} } = $IT;
}
- return (\%itemtypes);
+ return ( \%itemtypes );
}
-# FIXME this function is better and should replace GetItemTypes everywhere
sub get_itemtypeinfos_of {
my @itemtypes = @_;
@@ -312,21 +226,93 @@
description,
notforloan
FROM itemtypes
- WHERE itemtype IN ('.join(',', map({"'".$_."'"} @itemtypes)).')
+ WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
';
- return get_infos_of($query, 'itemtype');
+ return get_infos_of( $query, 'itemtype' );
}
-sub ItemType {
- my ($type)=@_;
+# this is temporary until we separate collection codes and item types
+sub GetCcodes {
+ my $count = 0;
+ my @results;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select description from itemtypes where itemtype=?");
- $sth->execute($type);
- my $dat=$sth->fetchrow_hashref;
+ my $sth =
+ $dbh->prepare(
+ "SELECT * FROM authorised_values ORDER BY authorised_value");
+ $sth->execute;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ if ( $data->{category} eq "CCODE" ) {
+ $count++;
+ $results[$count] = $data;
+
+ #warn "data: $data";
+ }
+ }
$sth->finish;
- return ($dat->{'description'});
+ return ( $count, @results );
}
+
+=head2
+
+grab itemlost authorized values
+
+=cut
+
+sub GetAuthItemlost {
+ my $itemlost = shift;
+ my $count = 0;
+ my @results;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "SELECT * FROM authorised_values ORDER BY authorised_value");
+ $sth->execute;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ if ( $data->{category} eq "ITEMLOST" ) {
+ $count++;
+ if ( $itemlost eq $data->{'authorised_value'} ) {
+ $data->{'selected'} = 1;
+ }
+ $results[$count] = $data;
+
+ #warn "data: $data";
+ }
+ }
+ $sth->finish;
+ return ( $count, @results );
+}
+
+=head2 GetAuthItembinding
+
+grab itemlost authorized values
+
+=cut
+
+sub GetAuthItembinding {
+ my $itembinding = shift;
+ my $count = 0;
+ my @results;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "SELECT * FROM authorised_values ORDER BY authorised_value");
+ $sth->execute;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ if ( $data->{category} eq "BINDING" ) {
+ $count++;
+ if ( $itembinding eq $data->{'authorised_value'} ) {
+ $data->{'selected'} = 1;
+ }
+ $results[$count] = $data;
+
+ #warn "data: $data";
+ }
+ }
+ $sth->finish;
+ return ( $count, @results );
+}
+
=head2 getauthtypes
$authtypes = &getauthtypes();
@@ -365,25 +351,27 @@
=cut
sub getauthtypes {
-# returns a reference to a hash of references to authtypes...
+
+ # returns a reference to a hash of references to authtypes...
my %authtypes;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from auth_types order by authtypetext");
+ my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
$sth->execute;
- while (my $IT=$sth->fetchrow_hashref) {
- $authtypes{$IT->{'authtypecode'}}=$IT;
+ while ( my $IT = $sth->fetchrow_hashref ) {
+ $authtypes{ $IT->{'authtypecode'} } = $IT;
}
- return (\%authtypes);
+ return ( \%authtypes );
}
sub getauthtype {
my ($authtypecode) = @_;
-# returns a reference to a hash of references to authtypes...
+
+ # returns a reference to a hash of references to authtypes...
my %authtypes;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from auth_types where authtypecode=?");
+ my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
$sth->execute($authtypecode);
- my $res=$sth->fetchrow_hashref;
+ my $res = $sth->fetchrow_hashref;
return $res;
}
@@ -426,16 +414,18 @@
=cut
sub getframeworks {
-# returns a reference to a hash of references to branches...
+
+ # returns a reference to a hash of references to branches...
my %itemtypes;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from biblios_framework");
+ my $sth = $dbh->prepare("select * from biblio_framework");
$sth->execute;
- while (my $IT=$sth->fetchrow_hashref) {
- $itemtypes{$IT->{'frameworkcode'}}=$IT;
+ while ( my $IT = $sth->fetchrow_hashref ) {
+ $itemtypes{ $IT->{'frameworkcode'} } = $IT;
}
- return (\%itemtypes);
+ return ( \%itemtypes );
}
+
=head2 getframeworkinfo
$frameworkinfo = &getframeworkinfo($frameworkcode);
@@ -447,13 +437,13 @@
sub getframeworkinfo {
my ($frameworkcode) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from biblios_framework where frameworkcode=?");
+ my $sth =
+ $dbh->prepare("select * from biblio_framework where frameworkcode=?");
$sth->execute($frameworkcode);
my $res = $sth->fetchrow_hashref;
return $res;
}
-
=head2 getitemtypeinfo
$itemtype = &getitemtype($itemtype);
@@ -465,11 +455,11 @@
sub getitemtypeinfo {
my ($itemtype) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
+ my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
$sth->execute($itemtype);
my $res = $sth->fetchrow_hashref;
- $res->{imageurl} = getitemtypeimagesrcfromurl($res->{imageurl});
+ $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
return $res;
}
@@ -477,35 +467,28 @@
sub getitemtypeimagesrcfromurl {
my ($imageurl) = @_;
- if (defined $imageurl and $imageurl !~ m/^http/) {
- $imageurl =
- getitemtypeimagesrc()
- .'/'.$imageurl
- ;
+ if ( defined $imageurl and $imageurl !~ m/^http/ ) {
+ $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
}
return $imageurl;
}
sub getitemtypeimagedir {
- return
- C4::Context->intrahtdocs
- .'/'.C4::Context->preference('template')
- .'/itemtypeimg'
- ;
+ return C4::Context->opachtdocs . '/'
+ . C4::Context->preference('template')
+ . '/itemtypeimg';
}
sub getitemtypeimagesrc {
- return
- '/intranet-tmpl'
- .'/'.C4::Context->preference('template')
- .'/itemtypeimg'
- ;
+ return '/opac-tmpl' . '/'
+ . C4::Context->preference('template')
+ . '/itemtypeimg';
}
-=head2 getprinters
+=head2 GetPrinters
- $printers = &getprinters($env);
+ $printers = &GetPrinters($env);
@queues = keys %$printers;
Returns information about existing printer queues.
@@ -518,168 +501,44 @@
=cut
-sub getprinters {
+sub GetPrinters {
my ($env) = @_;
my %printers;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from printers");
+ my $sth = $dbh->prepare("select * from printers");
$sth->execute;
- while (my $printer=$sth->fetchrow_hashref) {
- $printers{$printer->{'printqueue'}}=$printer;
+ while ( my $printer = $sth->fetchrow_hashref ) {
+ $printers{ $printer->{'printqueue'} } = $printer;
}
- return (\%printers);
+ return ( \%printers );
}
-sub getbranch ($$) {
- my($query, $branches) = @_; # get branch for this query from branches
- my $branch = $query->param('branch');
- ($branch) || ($branch = $query->cookie('branch'));
- ($branches->{$branch}) || ($branch=(keys %$branches)[0]);
- return $branch;
-}
-
-=item getbranchdetail
-
- $branchname = &getbranchdetail($branchcode);
+=head2 GetPrinter
-Given the branch code, the function returns the corresponding
-branch name for a comprehensive information display
+$printer = GetPrinter( $query, $printers );
=cut
-sub getbranchdetail
-{
- my ($branchcode) = @_;
- my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT * FROM branches WHERE branchcode = ?");
- $sth->execute($branchcode);
- my $branchname = $sth->fetchrow_hashref();
- $sth->finish();
- return $branchname;
-} # sub getbranchname
-
-
-sub getprinter ($$) {
- my($query, $printers) = @_; # get printer for this query from printers
+sub GetPrinter ($$) {
+ my ( $query, $printers ) = @_; # get printer for this query from printers
my $printer = $query->param('printer');
- ($printer) || ($printer = $query->cookie('printer')) || ($printer='');
- ($printers->{$printer}) || ($printer = (keys %$printers)[0]);
+ my %cookie = $query->cookie('userenv');
+ ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
+ ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
return $printer;
}
-=item getalllanguages
-
- (@languages) = &getalllanguages($type);
- (@languages) = &getalllanguages($type,$theme);
+=item getnbpages
-Returns an array of all available languages.
+Returns the number of pages to display in a pagination bar, given the number
+of items and the number of items per page.
=cut
-sub getalllanguages {
- my $type=shift;
- my $theme=shift;
- my $htdocs;
- my @languages;
- if ($type eq 'opac') {
- $htdocs=C4::Context->config('opachtdocs');
- if ($theme and -d "$htdocs/$theme") {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- push @languages, $language;
- }
- return sort @languages;
- } else {
- my $lang;
- foreach my $theme (getallthemes('opac')) {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- $lang->{$language}=1;
- }
- }
- @languages=keys %$lang;
- return sort @languages;
- }
- } elsif ($type eq 'intranet') {
- $htdocs=C4::Context->config('intrahtdocs');
- if ($theme and -d "$htdocs/$theme") {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- push @languages, $language;
- }
- return sort @languages;
- } else {
- my $lang;
- foreach my $theme (getallthemes('opac')) {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- $lang->{$language}=1;
- }
- }
- @languages=keys %$lang;
- return sort @languages;
- }
- } else {
- my $lang;
- my $htdocs=C4::Context->config('intrahtdocs');
- foreach my $theme (getallthemes('intranet')) {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- $lang->{$language}=1;
- }
- }
- $htdocs=C4::Context->config('opachtdocs');
- foreach my $theme (getallthemes('opac')) {
- opendir D, "$htdocs/$theme";
- foreach my $language (readdir D) {
- next if $language=~/^\./;
- next if $language eq 'all';
- next if $language=~ /png$/;
- next if $language=~ /css$/;
- next if $language=~ /CVS$/;
- next if $language=~ /itemtypeimg$/;
- next if $language=~ /\.txt$/i; #Don't read the readme.txt !
- $lang->{$language}=1;
- }
- }
- @languages=keys %$lang;
- return sort @languages;
- }
+sub getnbpages {
+ my ( $nb_items, $nb_items_per_page ) = @_;
+
+ return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
}
=item getallthemes
@@ -692,133 +551,161 @@
=cut
sub getallthemes {
- my $type=shift;
+ my $type = shift;
my $htdocs;
my @themes;
- if ($type eq 'intranet') {
- $htdocs=C4::Context->config('intrahtdocs');
- } else {
- $htdocs=C4::Context->config('opachtdocs');
+ if ( $type eq 'intranet' ) {
+ $htdocs = C4::Context->config('intrahtdocs');
+ }
+ else {
+ $htdocs = C4::Context->config('opachtdocs');
}
opendir D, "$htdocs";
- my @dirlist=readdir D;
+ my @dirlist = readdir D;
foreach my $directory (@dirlist) {
-d "$htdocs/$directory/en" and push @themes, $directory;
}
return @themes;
}
-=item getnbpages
-
-Returns the number of pages to display in a pagination bar, given the number
-of items and the number of items per page.
-
-=cut
-
-sub getnbpages {
- my ($nb_items, $nb_items_per_page) = @_;
-
- return int(($nb_items - 1) / $nb_items_per_page) + 1;
-}
-
-
-=head2 getcities (OUEST-PROVENCE)
-
- ($id_cityarrayref, $city_hashref) = &getcities();
-
-Looks up the different city and zip in the database. Returns two
-elements: a reference-to-array, which lists the zip city
-codes, and a reference-to-hash, which maps the name of the city.
-WHERE =>OUEST PROVENCE OR EXTERIEUR
-
-=cut
-sub getcities {
- #my ($type_city) = @_;
- my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select cityid,city_name from cities order by cityid ");
- #$sth->execute($type_city);
- $sth->execute();
- my %city;
- my @id;
-# insert empty value to create a empty choice in cgi popup
-
-while (my $data=$sth->fetchrow_hashref){
-
- push @id,$data->{'cityid'};
- $city{$data->{'cityid'}}=$data->{'city_name'};
- }
-
- #test to know if the table contain some records if no the function return nothing
- my $id=@id;
- $sth->finish;
- if ($id eq 0)
+sub getFacets {
+ my $facets;
+ if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
+ $facets = [
+ {
+ link_value => 'su-to',
+ label_value => 'Topics',
+ tags =>
+ [ '600', '601', '602', '603', '604', '605', '606', '610' ],
+ subfield => 'a',
+ },
{
- return();
+ link_value => 'su-geo',
+ label_value => 'Places',
+ tags => ['651'],
+ subfield => 'a',
+ },
+ {
+ link_value => 'su-ut',
+ label_value => 'Titles',
+ tags => [ '500', '501', '502', '503', '504', ],
+ subfield => 'a',
+ },
+ {
+ link_value => 'au',
+ label_value => 'Authors',
+ tags => [ '700', '701', '702', ],
+ subfield => 'a',
+ },
+ {
+ link_value => 'se',
+ label_value => 'Series',
+ tags => ['225'],
+ subfield => 'a',
+ },
+ {
+ link_value => 'branch',
+ label_value => 'Branches',
+ tags => [ '995', ],
+ subfield => 'b',
+ expanded => '1',
+ },
+ ];
}
- else{
- unshift (@id ,"");
- return(\@id,\%city);
+ else {
+ $facets = [
+ {
+ link_value => 'su-to',
+ label_value => 'Topics',
+ tags => ['650'],
+ subfield => 'a',
+ },
+
+ # {
+ # link_value => 'su-na',
+ # label_value => 'People and Organizations',
+ # tags => ['600', '610', '611'],
+ # subfield => 'a',
+ # },
+ {
+ link_value => 'su-geo',
+ label_value => 'Places',
+ tags => ['651'],
+ subfield => 'a',
+ },
+ {
+ link_value => 'su-ut',
+ label_value => 'Titles',
+ tags => ['630'],
+ subfield => 'a',
+ },
+ {
+ link_value => 'au',
+ label_value => 'Authors',
+ tags => [ '100', '110', '700', ],
+ subfield => 'a',
+ },
+ {
+ link_value => 'se',
+ label_value => 'Series',
+ tags => [ '440', '490', ],
+ subfield => 'a',
+ },
+ {
+ link_value => 'branch',
+ label_value => 'Branches',
+ tags => [ '952', ],
+ subfield => 'b',
+ expanded => '1',
+ },
+ ];
}
+ return $facets;
}
+=head2 get_infos_of
-=head2 getroadtypes (OUEST-PROVENCE)
+Return a href where a key is associated to a href. You give a query, the
+name of the key among the fields returned by the query. If you also give as
+third argument the name of the value, the function returns a href of scalar.
- ($idroadtypearrayref, $roadttype_hashref) = &getroadtypes();
+ my $query = '
+SELECT itemnumber,
+ notforloan,
+ barcode
+ FROM items
+';
-Looks up the different road type . Returns two
-elements: a reference-to-array, which lists the id_roadtype
-codes, and a reference-to-hash, which maps the road type of the road .
+ # generic href of any information on the item, href of href.
+ my $iteminfos_of = get_infos_of($query, 'itemnumber');
+ print $iteminfos_of->{$itemnumber}{barcode};
+ # specific information, href of scalar
+ my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
+ print $barcode_of_item->{$itemnumber};
=cut
-sub getroadtypes {
+
+sub get_infos_of {
+ my ( $query, $key_name, $value_name ) = @_;
+
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select roadtypeid,road_type from roadtype order by road_type ");
+
+ my $sth = $dbh->prepare($query);
$sth->execute();
- my %roadtype;
- my @id;
-# insert empty value to create a empty choice in cgi popup
-while (my $data=$sth->fetchrow_hashref){
- push @id,$data->{'roadtypeid'};
- $roadtype{$data->{'roadtypeid'}}=$data->{'road_type'};
+
+ my %infos_of;
+ while ( my $row = $sth->fetchrow_hashref ) {
+ if ( defined $value_name ) {
+ $infos_of{ $row->{$key_name} } = $row->{$value_name};
}
- #test to know if the table contain some records if no the function return nothing
- my $id=@id;
- $sth->finish;
- if ($id eq 0)
- {
- return();
+ else {
+ $infos_of{ $row->{$key_name} } = $row;
}
- else{
- unshift (@id ,"");
- return(\@id,\%roadtype);
}
-}
-
-=head2 get_branchinfos_of
-
- my $branchinfos_of = get_branchinfos_of(@branchcodes);
-
-Associates a list of branchcodes to the information of the branch, taken in
-branches table.
-
-Returns a href where keys are branchcodes and values are href where keys are
-branch information key.
-
- print 'branchname is ', $branchinfos_of->{$code}->{branchname};
-
-=cut
-sub get_branchinfos_of {
- my @branchcodes = @_;
+ $sth->finish;
- my $query = '
-SELECT branchcode,
- branchname
- FROM branches
- WHERE branchcode IN ('.join(',', map({"'".$_."'"} @branchcodes)).')
-';
- return get_infos_of($query, 'branchcode');
+ return \%infos_of;
}
=head2 get_notforloan_label_of
@@ -840,13 +727,14 @@
}
=cut
+
sub get_notforloan_label_of {
my $dbh = C4::Context->dbh;
-my($tagfield,$tagsubfield)=MARCfind_marc_from_kohafield("notforloan","holdings");
+
my $query = '
SELECT authorised_value
- FROM holdings_subfield_structure
- WHERE tagfield =$tagfield and tagsubfield=$tagsubfield
+ FROM marc_subfield_structure
+ WHERE kohafield = \'items.notforloan\'
LIMIT 0, 1
';
my $sth = $dbh->prepare($query);
@@ -862,7 +750,7 @@
$sth = $dbh->prepare($query);
$sth->execute($statuscode);
my %notforloan_label_of;
- while (my $row = $sth->fetchrow_hashref) {
+ while ( my $row = $sth->fetchrow_hashref ) {
$notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
}
$sth->finish;
@@ -870,80 +758,468 @@
return \%notforloan_label_of;
}
-=head2 get_infos_of
+sub displaySortby {
+ my ($sort_by) = @_;
+ my $sort_by_loop = [
+ { value => "1=9523 >i", label => "Popularity (Most to Least)" },
+ { value => "1=9523 <i", label => "Popularity (Least to Most)" },
+ { value => "1=1003 <i", label => "Author (A-Z)" },
+ { value => "1=1003 >i", label => "Author (Z-A)" },
+ {
+ value => "1=20 <i",
+ label => "Call Number (Non-fiction 0-9 to Fiction A-Z)"
+ },
+ {
+ value => "1=20 >i",
+ label => "Call Number (Fiction Z-A to Non-fiction 9-0)"
+ },
+ { value => "1=31 >i", label => "Dates" },
+ {
+ value => "1=31 >i",
+ label =>
+ " Publication/Copyright Date: Newest to Oldest"
+ },
+ {
+ value => "1=31 <i",
+ label =>
+ " Publication/Copyright Date: Oldest to Newest"
+ },
+ {
+ value => "1=32 >i",
+ label => " Acquisition Date: Newest to Oldest"
+ },
+ {
+ value => "1=32 <i",
+ label => " Acquisition Date: Oldest to Newest"
+ },
+ { value => "1=36 <i", label => "Title (A-Z)" },
+ { value => "1=36 >i", label => "Title (Z-A)" },
+ ];
+ for my $hash (@$sort_by_loop) {
-Return a href where a key is associated to a href. You give a query, the
-name of the key among the fields returned by the query. If you also give as
-third argument the name of the value, the function returns a href of scalar.
+ #warn "sort by: $sort_by ... hash:".$hash->{value};
+ if ($sort_by && $hash->{value} eq $sort_by ) {
+ $hash->{selected} = "selected";
+ }
+ }
+ return $sort_by_loop;
- my $query = '
-SELECT itemnumber,
- notforloan,
- barcode
- FROM items
-';
+}
- # generic href of any information on the item, href of href.
- my $iteminfos_of = get_infos_of($query, 'itemnumber');
- print $iteminfos_of->{$itemnumber}{barcode};
+sub displayIndexes {
+ my $indexes = [
+ { value => '', label => 'Keyword' },
+ { value => 'au', label => 'Author' },
+ {
+ value => 'au,phr',
+ label => ' Author Phrase'
+ },
+ { value => 'cpn', label => ' Corporate Name' },
+ { value => 'cfn', label => ' Conference Name' },
+ {
+ value => 'cpn,phr',
+ label => ' Corporate Name Phrase'
+ },
+ {
+ value => 'cfn,phr',
+ label => ' Conference Name Phrase'
+ },
+ { value => 'pn', label => ' Personal Name' },
+ {
+ value => 'pn,phr',
+ label => ' Personal Name Phrase'
+ },
+ { value => 'ln', label => 'Language' },
+
+ # { value => 'mt', label => 'Material Type' },
+ # { value => 'mt,phr', label => 'Material Type Phrase' },
+ # { value => 'mc', label => 'Musical Composition' },
+ # { value => 'mc,phr', label => 'Musical Composition Phrase' },
+
+ { value => 'nt', label => 'Notes/Comments' },
+ { value => 'pb', label => 'Publisher' },
+ { value => 'pl', label => 'Publisher Location' },
+ { value => 'sn', label => 'Standard Number' },
+ { value => 'nb', label => ' ISBN' },
+ { value => 'ns', label => ' ISSN' },
+ { value => 'lcn', label => ' Call Number' },
+ { value => 'su', label => 'Subject' },
+ {
+ value => 'su,phr',
+ label => ' Subject Phrase'
+ },
+
+# { value => 'de', label => ' Descriptor' },
+# { value => 'ge', label => ' Genre/Form' },
+# { value => 'gc', label => ' Geographic Coverage' },
+
+# { value => 'nc', label => ' Named Corporation and Conference' },
+# { value => 'na', label => ' Named Person' },
+
+ { value => 'ti', label => 'Title' },
+ { value => 'ti,phr', label => ' Title Phrase' },
+ { value => 'se', label => ' Series Title' },
+ ];
+ return $indexes;
+}
+
+sub displaySubtypesLimit {
+ my $outer_subtype_limits_loop = [
+
+ { # in MARC21, aud codes are stored in 008/22 (Target audience)
+ name => "limit",
+ inner_subtype_limits_loop => [
+ {
+ value => '',
+ label => 'Any Audience',
+ selected => "selected"
+ },
+ { value => 'aud:a', label => 'Easy', },
+ { value => 'aud:c', label => 'Juvenile', },
+ { value => 'aud:d', label => 'Young Adult', },
+ { value => 'aud:e', label => 'Adult', },
+
+ ],
+ },
+ { # in MARC21, fic is in 008/33, bio in 008/34, mus in LDR/06
+ name => "limit",
+ inner_subtype_limits_loop => [
+ { value => '', label => 'Any Content', selected => "selected" },
+ { value => 'fic:1', label => 'Fiction', },
+ { value => 'fic:0', label => 'Non Fiction', },
+ { value => 'bio:b', label => 'Biography', },
+ { value => 'mus:j', label => 'Musical recording', },
+ { value => 'mus:i', label => 'Non-musical recording', },
+
+ ],
+ },
+ { # MARC21, these are codes stored in 007/00-01
+ name => "limit",
+ inner_subtype_limits_loop => [
+ { value => '', label => 'Any Format', selected => "selected" },
+ { value => 'l-format:ta', label => 'Regular print', },
+ { value => 'l-format:tb', label => 'Large print', },
+ { value => 'l-format:fk', label => 'Braille', },
+ { value => '', label => '-----------', },
+ { value => 'l-format:sd', label => 'CD audio', },
+ { value => 'l-format:ss', label => 'Cassette recording', },
+ {
+ value => 'l-format:vf',
+ label => 'VHS tape / Videocassette',
+ },
+ { value => 'l-format:vd', label => 'DVD video / Videodisc', },
+ { value => 'l-format:co', label => 'CD Software', },
+ { value => 'l-format:cr', label => 'Website', },
+
+ ],
+ },
+ { # in MARC21, these are codes in 008/24-28
+ name => "limit",
+ inner_subtype_limits_loop => [
+ { value => '', label => 'Additional Content Types', },
+ { value => 'ctype:a', label => 'Abstracts/summaries', },
+ { value => 'ctype:b', label => 'Bibliographies', },
+ { value => 'ctype:c', label => 'Catalogs', },
+ { value => 'ctype:d', label => 'Dictionaries', },
+ { value => 'ctype:e', label => 'Encyclopedias ', },
+ { value => 'ctype:f', label => 'Handbooks', },
+ { value => 'ctype:g', label => 'Legal articles', },
+ { value => 'ctype:i', label => 'Indexes', },
+ { value => 'ctype:j', label => 'Patent document', },
+ { value => 'ctype:k', label => 'Discographies', },
+ { value => 'ctype:l', label => 'Legislation', },
+ { value => 'ctype:m', label => 'Theses', },
+ { value => 'ctype:n', label => 'Surveys', },
+ { value => 'ctype:o', label => 'Reviews', },
+ { value => 'ctype:p', label => 'Programmed texts', },
+ { value => 'ctype:q', label => 'Filmographies', },
+ { value => 'ctype:r', label => 'Directories', },
+ { value => 'ctype:s', label => 'Statistics', },
+ { value => 'ctype:t', label => 'Technical reports', },
+ { value => 'ctype:v', label => 'Legal cases and case notes', },
+ { value => 'ctype:w', label => 'Law reports and digests', },
+ { value => 'ctype:z', label => 'Treaties ', },
+ ],
+ },
+ ];
+ return $outer_subtype_limits_loop;
+}
- # specific information, href of scalar
- my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
- print $barcode_of_item->{$itemnumber};
+sub displayLimitTypes {
+ my $outer_limit_types_loop = [
+
+ {
+ inner_limit_types_loop => [
+ {
+ label => "Books",
+ id => "mc-books",
+ name => "limit",
+ value => "(mc-collection:AF or mc-collection:MYS or mc-collection:SCI or mc-collection:NF or mc-collection:YA or mc-collection:BIO or mc-collection:LP or mc-collection:LPNF)",
+ icon => "search-books.gif",
+ title =>
+"Books, Pamphlets, Technical reports, Manuscripts, Legal papers, Theses and dissertations",
+ },
+
+ {
+ label => "Movies",
+ id => "mc-movies",
+ name => "limit",
+ value => "(mc-collection:DVD or mc-collection:AV or mc-collection:AVJ or mc-collection:AVJN or mc-collection:AVJNF or mc-collection:AVNF)",
+ icon => "search-movies.gif",
+ title =>
+"Motion pictures, Videorecordings, Filmstrips, Slides, Transparencies, Photos, Cards, Charts, Drawings",
+ },
+
+ {
+ label => "Music",
+ id => "mc-music",
+ name => "limit",
+ value => "(mc-collection:CDM)",
+ icon => "search-music.gif",
+ title => "Spoken, Books on CD and Cassette",
+ },
+ ],
+ },
+ {
+ inner_limit_types_loop => [
+ {
+ label => "Audio Books",
+ id => "mc-audio-books",
+ name => "limit",
+ value => "(mc-collection:AB or mc-collection:AC or mc-collection:JAC or mc-collection:YAC)",
+ icon => "search-audio-books.gif",
+ title => "Spoken, Books on CD and Cassette",
+ },
+
+ {
+ label => "Local History Materials",
+ id => "mc-local-history",
+ name => "limit",
+ value => "mc-collection:LH",
+ icon => "Local history.gif",
+ title => "Local History Materials",
+ },
+
+ {label => "Large Print",
+ id => "mc-large-print",
+ name => "limit",
+ value => "(mc-collection:LP or mc-collection:LPNF)",
+ icon => "search-large-print.gif ",
+ title => "Large Print",},
+ ],
+ },
+{ inner_limit_types_loop => [
+ {label => "Kids",
+ id => "mc-kids",
+ name => "limit",
+ value => "(mc-collection:EASY or mc-collection:JNF or mc-collection:JF or mc-collection:JREF or mc-collection:JB)",
+ icon => "search-kids.gif",
+ title => "Music",},
+
+ {label => "Software/Internet",
+ id => "mc-sofware-web",
+ name => "limit",
+ value => "(mc-collection:CDR)",
+ icon => "search-software-web.gif",
+ title => "Kits",},
+
+ {label => "Reference",
+ id => "mc-reference",
+ name => "limit",
+ value => "mc-collection:REF",
+ icon => "search-reference.gif",
+ title => "Reference",},
+
+ ],
+ },
+
+ ];
+ return $outer_limit_types_loop;
+}
+
+sub displayServers {
+ my ( $position, $type ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $strsth = "SELECT * FROM z3950servers where 1";
+ $strsth .= " AND position=\"$position\"" if ($position);
+ $strsth .= " AND type=\"$type\"" if ($type);
+ my $rq = $dbh->prepare($strsth);
+ $rq->execute;
+ my @primaryserverloop;
+
+ while ( my $data = $rq->fetchrow_hashref ) {
+ my %cell;
+ $cell{label} = $data->{'description'};
+ $cell{id} = $data->{'name'};
+ $cell{value} =
+ $data->{host}
+ . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
+ . $data->{database}
+ if ( $data->{host} );
+ $cell{checked} = $data->{checked};
+ push @primaryserverloop,
+ {
+ label => $data->{description},
+ id => $data->{name},
+ name => "server",
+ value => $data->{host} . ":"
+ . $data->{port} . "/"
+ . $data->{database},
+ checked => "checked",
+ icon => $data->{icon},
+ zed => $data->{type} eq 'zed',
+ opensearch => $data->{type} eq 'opensearch'
+ };
+ }
+ return \@primaryserverloop;
+}
+
+sub displaySecondaryServers {
+
+# my $secondary_servers_loop = [
+# { inner_sup_servers_loop => [
+# {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
+# {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
+# {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
+# {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
+# ],
+# },
+# ];
+ return; #$secondary_servers_loop;
+}
+
+sub GetDepartements {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "SELECT authorised_value,lib FROM authorised_values WHERE category='DPT'
+ "
+ );
+ $sth->execute;
+ my @getdepartements;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $getdepartements[$i] = $data;
+ $i++;
+ }
+ $sth->finish;
+ return (@getdepartements);
+}
+
+sub GetDepartementLib {
+ my ($authorisedvalue) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+"SELECT lib,authorised_value FROM authorised_values WHERE category='DPT' AND authorised_value=?
+ "
+ );
+ $sth->execute($authorisedvalue);
+ my (@lib) = $sth->fetchrow_array;
+ $sth->finish;
+ return (@lib);
+}
+
+=head2 GetAuthorisedValues
+
+$authvalues = GetAuthorisedValues($category);
+
+this function get all authorised values from 'authosied_value' table into a reference to array which
+each value containt an hashref.
+
+Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
=cut
-sub get_infos_of {
- my ($query, $key_name, $value_name) = @_;
+sub GetAuthorisedValues {
+ my $category = shift;
my $dbh = C4::Context->dbh;
+ my $query = "SELECT * FROM authorised_values";
+ $query .= " WHERE category = '" . $category . "'" if $category;
my $sth = $dbh->prepare($query);
- $sth->execute();
+ $sth->execute;
+ my $data = $sth->fetchall_arrayref({});
+ return $data;
+}
- my %infos_of;
- while (my $row = $sth->fetchrow_hashref) {
- if (defined $value_name) {
- $infos_of{ $row->{$key_name} } = $row->{$value_name};
+=item fixEncoding
+
+ $marcrecord = &fixEncoding($marcblob);
+
+Returns a well encoded marcrecord.
+
+=cut
+sub FixEncoding {
+ my $marc=shift;
+ my $record = MARC::Record->new_from_usmarc($marc);
+ if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
+ use Encode::Guess;
+ my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
+ $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
+ my $decoder = guess_encoding($marc, qw/utf8 latin1/);
+# die $decoder unless ref($decoder);
+ if (ref($decoder)) {
+ my $newRecord=MARC::Record->new();
+ foreach my $field ($record->fields()){
+ if ($field->tag()<'010'){
+ $newRecord->insert_grouped_field($field);
+ } else {
+ my $newField;
+ my $createdfield=0;
+ foreach my $subfield ($field->subfields()){
+ if ($createdfield){
+ if (($newField->tag eq '100')) {
+ substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
+ substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
}
- else {
- $infos_of{ $row->{$key_name} } = $row;
+ map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
+ $newField->add_subfields($subfield->[0]=>$subfield->[1]);
+ } else {
+ map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
+ $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
+ $createdfield=1;
}
}
- $sth->finish;
-
- 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 $query=new CGI;
-my $lang=$query->cookie('KohaOpacLanguage');
-$lang="en" unless $lang;
-my @facets;
-my $sth=$dbh->prepare("SELECT facets_label_$lang,kohafield FROM facets where (facets_label_$lang<>'' ) group by facets_label_$lang");
-my $sth2=$dbh->prepare("SELECT * FROM facets where facets_label_$lang=?");
-$sth->execute();
-while (my ($label,$kohafield)=$sth->fetchrow){
- $sth2->execute($label);
-my (@tags, at subfield);
- while (my $data=$sth2->fetchrow_hashref){
- push @tags,$data->{tagfield} ;
- push @subfield,$data->{subfield} ;
- }
- my $facet = {
- link_value =>"kohafield=$kohafield",
- label_value =>$label,
- tags => \@tags,
- subfield =>\@subfield,
- } ;
- push @facets,$facet;
-}
- return \@facets;
+ $newRecord->insert_grouped_field($newField);
+ }
+ }
+ # warn $newRecord->as_formatted();
+ return $newRecord;
+ } else {
+ return $record;
+ }
+ } else {
+ return $record;
+ }
}
+=head2 GetKohaAuthorisedValues
+
+ Takes $dbh , $kohafield as parameters.
+ returns hashref of authvalCode => liblibrarian
+ or undef if no authvals defined for kohafield.
+
+=cut
+
+sub GetKohaAuthorisedValues {
+ my ($kohafield) = @_;
+ my %values;
+ my $dbh = C4::Context->dbh;
+ my $sthnflstatus = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=?');
+ $sthnflstatus->execute($kohafield);
+ my $authorised_valuecode = $sthnflstatus->fetchrow;
+ if ($authorised_valuecode) {
+ $sthnflstatus = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
+ $sthnflstatus->execute($authorised_valuecode);
+ while ( my ($val, $lib) = $sthnflstatus->fetchrow_array ) {
+ $values{$val}= $lib;
+ }
+ }
+ return \%values;
+}
1;
+
__END__
=back
Index: Labels.pm
===================================================================
RCS file: /sources/koha/koha/C4/Labels.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- Labels.pm 10 Jul 2006 23:36:02 -0000 1.3
+++ Labels.pm 9 Mar 2007 14:31:47 -0000 1.4
@@ -21,11 +21,13 @@
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
-#use Data::Dumper;
-use PDF::Reuse;
+use PDF::Reuse;
+use Text::Wrap;
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.4 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -41,7 +43,13 @@
@EXPORT = qw(
&get_label_options &get_label_items
&build_circ_barcode &draw_boundaries
- &draw_box
+ &drawbox &GetActiveLabelTemplate
+ &GetAllLabelTemplates &DeleteTemplate
+ &GetSingleLabelTemplate &SaveTemplate
+ &CreateTemplate &SetActiveTemplate
+ &SaveConf &DrawSpineText &GetTextWrapCols
+ &GetUnitsValue &DrawBarcode
+
);
=item get_label_options;
@@ -52,6 +60,7 @@
Return a pointer on a hash list containing info from labels_conf table in Koha DB.
=cut
+
#'
sub get_label_options {
my $dbh = C4::Context->dbh;
@@ -63,6 +72,206 @@
return $conf_data;
}
+sub GetUnitsValue {
+ my ($units) = @_;
+ my $unitvalue;
+
+ $unitvalue = '1' if ( $units eq 'POINT' );
+ $unitvalue = '2.83464567' if ( $units eq 'MM' );
+ $unitvalue = '28.3464567' if ( $units eq 'CM' );
+ $unitvalue = 72 if ( $units eq 'INCH' );
+ warn $units, $unitvalue;
+ return $unitvalue;
+}
+
+sub GetTextWrapCols {
+ my ( $fontsize, $label_width ) = @_;
+ my $string = "0";
+ my $left_text_margin = 3;
+ my ( $strtmp, $strwidth );
+ my $count = 0;
+ my $textlimit = $label_width - $left_text_margin;
+
+ while ( $strwidth < $textlimit ) {
+ $strwidth = prStrWidth( $string, 'C', $fontsize );
+ $string = $string . '0';
+
+ # warn "strwidth $strwidth, $textlimit, $string";
+ $count++;
+ }
+ return $count;
+}
+
+sub GetActiveLabelTemplate {
+ my $dbh = C4::Context->dbh;
+ my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my $active_tmpl = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $active_tmpl;
+}
+
+sub GetSingleLabelTemplate {
+ my ($tmpl_code) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = " SELECT * FROM labels_templates where tmpl_code = ?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($tmpl_code);
+ my $template = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $template;
+}
+
+sub SetActiveTemplate {
+
+ my ($tmpl_id) = @_;
+ warn "TMPL_ID = $tmpl_id";
+ my $dbh = C4::Context->dbh;
+ my $query = " UPDATE labels_templates SET active = NULL";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+
+ $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
+ $sth = $dbh->prepare($query);
+ $sth->execute($tmpl_id);
+ $sth->finish;
+}
+
+sub DeleteTemplate {
+ my ($tmpl_code) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = " DELETE FROM labels_templates where tmpl_code = ?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($tmpl_code);
+ $sth->finish;
+}
+
+sub SaveTemplate {
+
+ my (
+ $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
+ $page_height, $label_width, $label_height, $topmargin,
+ $leftmargin, $cols, $rows, $colgap,
+ $rowgap, $active, $fontsize, $units
+ )
+ = @_;
+
+ #warn "FONTSIZE =$fontsize";
+
+ my $dbh = C4::Context->dbh;
+ my $query =
+ " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
+ page_height=?, label_width=?, label_height=?, topmargin=?,
+ leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, fontsize=?,
+ units=?
+ WHERE tmpl_id = ?";
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $tmpl_code, $tmpl_desc, $page_width, $page_height,
+ $label_width, $label_height, $topmargin, $leftmargin,
+ $cols, $rows, $colgap, $rowgap,
+ $fontsize, $units, $tmpl_id
+ );
+ $sth->finish;
+
+ SetActiveTemplate($tmpl_id) if ( $active eq '1' );
+}
+
+sub CreateTemplate {
+ my $tmpl_id;
+ my (
+ $tmpl_code, $tmpl_desc, $page_width, $page_height,
+ $label_width, $label_height, $topmargin, $leftmargin,
+ $cols, $rows, $colgap, $rowgap,
+ $active, $fontsize, $units
+ )
+ = @_;
+
+ my $dbh = C4::Context->dbh;
+
+ my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
+ page_height, label_width, label_height, topmargin,
+ leftmargin, cols, rows, colgap, rowgap, fontsize, units)
+ VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $tmpl_code, $tmpl_desc, $page_width, $page_height,
+ $label_width, $label_height, $topmargin, $leftmargin,
+ $cols, $rows, $colgap, $rowgap,
+ $fontsize, $units
+ );
+
+ warn "ACTIVE = $active";
+
+ if ( $active eq '1' ) {
+
+ # get the tmpl_id of the newly created template, then call SetActiveTemplate()
+ my $query =
+ "SELECT tmpl_id from labels_templates order by tmpl_id desc limit 1";
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+
+ my $data = $sth->fetchrow_hashref;
+ my $tmpl_id = $data->{'tmpl_id'};
+
+ SetActiveTemplate($tmpl_id);
+ $sth->finish;
+ }
+ return $tmpl_id;
+}
+
+sub GetAllLabelTemplates {
+ my $dbh = C4::Context->dbh;
+
+ # get the actual items to be printed.
+ my @data;
+ my $query = " Select * from labels_templates ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my @resultsloop;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @resultsloop, $data );
+ }
+ $sth->finish;
+
+ return @resultsloop;
+}
+
+sub SaveConf {
+
+ my (
+ $barcodetype, $title, $isbn, $itemtype,
+ $bcn, $dcn, $classif, $subclass,
+ $itemcallnumber, $author, $tmpl_id, $printingtype,
+ $guidebox, $startlabel
+ )
+ = @_;
+
+ my $dbh = C4::Context->dbh;
+ my $query2 = "DELETE FROM labels_conf";
+ my $sth2 = $dbh->prepare($query2);
+ $sth2->execute;
+ $query2 = "INSERT INTO labels_conf
+ ( barcodetype, title, isbn, itemtype, barcode,
+ dewey, class, subclass, itemcallnumber, author, printingtype,
+ guidebox, startlabel )
+ values ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? )";
+ $sth2 = $dbh->prepare($query2);
+ $sth2->execute(
+ $barcodetype, $title, $isbn, $itemtype,
+ $bcn, $dcn, $classif, $subclass,
+ $itemcallnumber, $author, $printingtype, $guidebox,
+ $startlabel
+ );
+ $sth2->finish;
+
+ SetActiveTemplate($tmpl_id);
+ return;
+}
+
=item get_label_items;
$options = get_label_items()
@@ -71,6 +280,7 @@
Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
=cut
+
#'
sub get_label_items {
my $dbh = C4::Context->dbh;
@@ -104,6 +314,136 @@
return @resultsloop;
}
+sub DrawSpineText {
+
+ my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
+ $text_wrap_cols, $item, $conf_data )
+ = @_;
+
+ $Text::Wrap::columns = $text_wrap_cols;
+ $Text::Wrap::separator = "\n";
+
+ my $str;
+
+ my $top_text_margin = ( $fontsize + 3 );
+ my $line_spacer = ($fontsize); # number of pixels between text rows.
+
+ # add your printable fields manually in here
+ my @fields =
+ qw (dewey isbn classification itemtype subclass itemcallnumber);
+ my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
+ my $hPos = ( $x_pos + $left_text_margin );
+
+ foreach my $field (@fields) {
+
+ # if the display option for this field is selected in the DB,
+ # and the item record has some values for this field, display it.
+ if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
+
+ # warn "CONF_TYPE = $field";
+
+ # get the string
+ $str = $$item->{"$field"};
+
+ # strip out naughty existing nl/cr's
+ $str =~ s/\n//g;
+ $str =~ s/\r//g;
+
+ # chop the string up into _upto_ 12 chunks
+ # and seperate the chunks with newlines
+
+ $str = wrap( "", "", "$str" );
+ $str = wrap( "", "", "$str" );
+
+ # split the chunks between newline's, into an array
+ my @strings = split /\n/, $str;
+
+ # then loop for each string line
+ foreach my $str (@strings) {
+
+ #warn "HPOS , VPOS $hPos, $vPos ";
+ prText( $hPos, $vPos, $str );
+ $vPos = $vPos - $line_spacer;
+ }
+ } # if field is valid
+ } #foreach feild
+}
+
+sub DrawBarcode {
+
+ my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
+ $barcode = '123456789';
+ my $num_of_bars = length($barcode);
+ my $bar_width = ( ( $width / 10 ) * 8 ); # %80 of lenght of label width
+ my $tot_bar_length;
+ my $bar_length;
+ my $guard_length = 10;
+ my $xsize_ratio;
+
+ if ( $barcodetype eq 'Code39' ) {
+ $bar_length = '14.4333333333333';
+ $tot_bar_length =
+ ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
+ $xsize_ratio = ( $bar_width / $tot_bar_length );
+ eval {
+ PDF::Reuse::Barcode::Code39(
+ x => ( $x_pos + ( $width / 10 ) ),
+ y => ( $y_pos + ( $height / 10 ) ),
+ value => "*$barcode*",
+ ySize => ( .02 * $height ),
+ xSize => $xsize_ratio,
+ hide_asterisk => $xsize_ratio,
+ );
+ };
+ if ($@) {
+ warn "$barcodetype, $barcode FAILED:$@";
+ }
+ }
+
+ elsif ( $barcodetype eq 'COOP2of5' ) {
+ $bar_length = '9.43333333333333';
+ $tot_bar_length =
+ ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
+ $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
+ eval {
+ PDF::Reuse::Barcode::COOP2of5(
+ x => ( $x_pos + ( $width / 10 ) ),
+ y => ( $y_pos + ( $height / 10 ) ),
+ value => $barcode,
+ ySize => ( .02 * $height ),
+ xSize => $xsize_ratio,
+ );
+ };
+ if ($@) {
+ warn "$barcodetype, $barcode FAILED:$@";
+ }
+ }
+
+ elsif ( $barcodetype eq 'Industrial2of5' ) {
+ $bar_length = '13.1333333333333';
+ $tot_bar_length =
+ ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
+ $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
+ eval {
+ PDF::Reuse::Barcode::Industrial2of5(
+ x => ( $x_pos + ( $width / 10 ) ),
+ y => ( $y_pos + ( $height / 10 ) ),
+ value => $barcode,
+ ySize => ( .02 * $height ),
+ xSize => $xsize_ratio,
+ );
+ };
+ if ($@) {
+ warn "$barcodetype, $barcode FAILED:$@";
+ }
+ }
+ my $moo2 = $tot_bar_length * $xsize_ratio;
+
+ warn " $x_pos, $y_pos, $barcode, $barcodetype\n";
+ warn
+"BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2 \n";
+}
+
=item build_circ_barcode;
build_circ_barcode( $x_pos, $y_pos, $barcode,
@@ -112,12 +452,11 @@
$item is the result of a previous call to get_label_items();
=cut
+
#'
sub build_circ_barcode {
my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
-#warn Dumper \$item;
-
#warn "value = $value\n";
#$DB::single = 1;
@@ -148,6 +487,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "EAN13BARCODE FAILED:$@";
}
@@ -155,21 +495,20 @@
}
elsif ( $barcodetype eq 'Code39' ) {
-
eval {
PDF::Reuse::Barcode::Code39(
x => ( $x_pos_circ + 9 ),
y => ( $y_pos + 15 ),
- value => $value,
-
# prolong => 2.96,
xSize => .85,
-
ySize => 1.3,
+ value => "*$value*",
+ #hide_asterisk => $xsize_ratio,
);
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "CODE39BARCODE $value FAILED:$@";
}
@@ -202,6 +541,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -233,6 +573,7 @@
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -255,6 +596,7 @@
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -276,6 +618,7 @@
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -297,6 +640,7 @@
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -317,6 +661,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -337,6 +682,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -358,6 +704,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -379,6 +726,7 @@
};
if ($@) {
$item->{'barcodeerror'} = 1;
+
#warn "BARCODE FAILED:$@";
}
@@ -400,11 +748,14 @@
#'
sub draw_boundaries {
- my ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
- $y_pos, $spine_width, $label_height, $circ_width) = @_;
+ my (
+ $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
+ $spine_width, $label_height, $circ_width
+ )
+ = @_;
my $y_pos_initial = ( ( 792 - 36 ) - 90 );
- my $y_pos = $y_pos_initial;
+ $y_pos = $y_pos_initial;
my $i = 1;
for ( $i = 1 ; $i <= 8 ; $i++ ) {
@@ -427,15 +778,22 @@
this is a low level sub, that draws a pdf box, it is called by draw_boxes
+FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
+
+and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
+
=cut
#'
sub drawbox {
my ( $llx, $lly, $urx, $ury ) = @_;
+ # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
+
my $str = "q\n"; # save the graphic state
+ $str .= "0.5 w\n"; # border color red
$str .= "1.0 0.0 0.0 RG\n"; # border color red
- $str .= "1 1 1 rg\n"; # fill color blue
+ $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
$str .= "$llx $lly $urx $ury re\n"; # a rectangle
$str .= "B\n"; # fill (and a little more)
$str .= "Q\n"; # save the graphic state
Index: Letters.pm
===================================================================
RCS file: /sources/koha/koha/C4/Letters.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- Letters.pm 25 Aug 2006 21:07:08 -0000 1.5
+++ Letters.pm 9 Mar 2007 14:31:47 -0000 1.6
@@ -21,14 +21,18 @@
use strict;
use Mail::Sendmail;
use C4::Date;
+use Date::Manip;
use C4::Suggestions;
use C4::Members;
+use C4::Log;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.6 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -48,33 +52,62 @@
=cut
@ISA = qw(Exporter);
- at EXPORT = qw(&GetLetterList &getletter &addalert &getalert &delalert &findrelatedto &sendalerts);
+ at EXPORT = qw(&GetLetters &getletter &addalert &getalert &delalert &findrelatedto &SendAlerts);
-=head2 GetLetterList
- parameter : $module : the name of the module
- This sub returns an array of hashes with all letters from a given module
- Each hash entry contains :
- - module : the module name
- - code : the code of the letter, char(20)
- - name : the complete name of the letter, char(200)
- - title : the title that will be used as "subject" in mails, char(200)
- - content : the content of the letter. Each field to be replaced by a value at runtime is enclosed in << and >>. The fields usually have the same name as in the DB
+=head2 GetLetters
+
+ $letters = &getletters($category);
+ returns informations about letters.
+ if needed, $category filters for letters given category
+ Create a letter selector with the following code
+
+=head3 in PERL SCRIPT
+
+my $letters = GetLetters($cat);
+my @letterloop;
+foreach my $thisletter (keys %$letters) {
+ my $selected = 1 if $thisletter eq $letter;
+ my %row =(value => $thisletter,
+ selected => $selected,
+ lettername => $letters->{$thisletter},
+ );
+ push @letterloop, \%row;
+}
+
+=head3 in TEMPLATE
+ <select name="letter">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="letterloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="lettername" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
=cut
-sub GetLetterList {
- my ($module) = @_;
+sub GetLetters {
+# returns a reference to a hash of references to ALL letters...
+ my $cat = shift;
+ my %letters;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("select * from letter where module=?");
- $sth->execute($module);
- my @result;
- while (my $line = $sth->fetchrow_hashref) {
- push @result,$line;
+ $dbh->quote($cat);
+ my $sth;
+ if ($cat ne ""){
+ my $query = "SELECT * FROM letter WHERE module = ? ORDER BY name";
+ $sth = $dbh->prepare($query);
+ $sth->execute($cat);
+ } else {
+ my $query = " SELECT * FROM letter ORDER BY name";
+ $sth = $dbh->prepare($query);
+ $sth->execute;
+ }
+ while (my $letter=$sth->fetchrow_hashref){
+ $letters{$letter->{'code'}}=$letter->{'name'};
}
- return @result;
+ return \%letters;
}
+
sub getletter {
my ($module,$code) = @_;
my $dbh = C4::Context->dbh;
@@ -182,7 +215,8 @@
return $result;
}
-=head2 sendalert
+=head2 SendAlerts
+
parameters :
- $type : the type of alert
- $externalid : the id of the "object" to query
@@ -192,7 +226,7 @@
=cut
-sub sendalerts {
+sub SendAlerts {
my ($type,$externalid,$letter)=@_;
my $dbh=C4::Context->dbh;
if ($type eq 'issue') {
@@ -218,7 +252,7 @@
foreach (@$alerts) {
# and parse borrower ...
my $innerletter = $letter;
- my $borinfo = getmember('',$_->{'borrowernumber'});
+ my $borinfo = GetMember('',$_->{'borrowernumber'});
parseletter($innerletter,'borrowers',$_->{'borrowernumber'});
# ... then send mail
if ($borinfo->{emailaddress}) {
@@ -232,16 +266,112 @@
}
}
}
+ elsif ($type eq 'claimacquisition') {
+# warn "sending issues...";
+ my $letter = getletter('claimacquisition',$letter);
+ # prepare the letter...
+ # search the biblionumber
+ my $strsth="select aqorders.*,aqbasket.*,biblio.*,biblioitems.* from aqorders LEFT JOIN aqbasket on aqbasket.basketno=aqorders.basketno LEFT JOIN biblio on aqorders.biblionumber=biblio.biblionumber LEFT JOIN biblioitems on aqorders.biblioitemnumber=biblioitems.biblioitemnumber where aqorders.ordernumber IN (".join(",",@$externalid).")";
+ my $sthorders=$dbh->prepare($strsth);
+ $sthorders->execute;
+ my $dataorders=$sthorders->fetchall_arrayref({});
+ parseletter($letter,'aqbooksellers',$dataorders->[0]->{booksellerid});
+ my $sthbookseller = $dbh->prepare("select * from aqbooksellers where id=?");
+ $sthbookseller->execute($dataorders->[0]->{booksellerid});
+ my $databookseller=$sthbookseller->fetchrow_hashref;
+ # parsing branch info
+ my $userenv = C4::Context->userenv;
+ parseletter($letter,'branches',$userenv->{branch});
+ # parsing librarian name
+ $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g;
+ $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g;
+ $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g;
+ foreach my $data (@$dataorders){
+ my $line=$1 if ($letter->{content}=~m/(<<.*>>)/);
+ foreach my $field (keys %$data){
+ $line =~ s/(<<[^\.]+.$field>>)/$data->{$field}/;
+ }
+ $letter->{content}=~ s/(<<.*>>)/$line\n\1/;
+ }
+ $letter->{content} =~ s/<<[^>]*>>//g;
+ my $innerletter = $letter;
+ # ... then send mail
+ if ($databookseller->{bookselleremail}||$databookseller->{contemail}) {
+ my %mail = ( To => $databookseller->{bookselleremail}.($databookseller->{contemail}?",".$databookseller->{contemail}:""),
+ From => $userenv->{emailaddress},
+ Subject => "".$innerletter->{title},
+ Message => "".$innerletter->{content},
+ 'Content-Type' => 'text/plain; charset="utf8"',
+ );
+ sendmail(%mail);
+ warn "sending to $mail{To} From $mail{From} subj $mail{Subject} Mess $mail{Message}";
+ }
+ if (C4::Context->preference("LetterLog")){
+ logaction($userenv->{number},"ACQUISITION","Send Acquisition claim letter","","order list : ".join(",",@$externalid)."\n$innerletter->{title}\n$innerletter->{content}")
+ }
+ }
+ elsif ($type eq 'claimissues') {
+# warn "sending issues...";
+ my $letter = getletter('claimissues',$letter);
+ # prepare the letter...
+ # search the biblionumber
+ my $strsth="select serial.*,subscription.*, biblio.title from serial LEFT JOIN subscription on serial.subscriptionid=subscription.subscriptionid LEFT JOIN biblio on serial.biblionumber=biblio.biblionumber where serial.serialid IN (".join(",",@$externalid).")";
+ my $sthorders=$dbh->prepare($strsth);
+ $sthorders->execute;
+ my $dataorders=$sthorders->fetchall_arrayref({});
+ parseletter($letter,'aqbooksellers',$dataorders->[0]->{aqbooksellerid});
+ my $sthbookseller = $dbh->prepare("select * from aqbooksellers where id=?");
+ $sthbookseller->execute($dataorders->[0]->{aqbooksellerid});
+ my $databookseller=$sthbookseller->fetchrow_hashref;
+ # parsing branch info
+ my $userenv = C4::Context->userenv;
+ parseletter($letter,'branches',$userenv->{branch});
+ # parsing librarian name
+ $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g;
+ $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g;
+ $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g;
+ foreach my $data (@$dataorders){
+ my $line=$1 if ($letter->{content}=~m/(<<.*>>)/);
+ foreach my $field (keys %$data){
+ $line =~ s/(<<[^\.]+.$field>>)/$data->{$field}/;
+ }
+ $letter->{content}=~ s/(<<.*>>)/$line\n\1/;
+ }
+ $letter->{content} =~ s/<<[^>]*>>//g;
+ my $innerletter = $letter;
+ # ... then send mail
+ if ($databookseller->{bookselleremail}||$databookseller->{contemail}) {
+ my %mail = ( To => $databookseller->{bookselleremail}.($databookseller->{contemail}?",".$databookseller->{contemail}:""),
+ From => $userenv->{emailaddress},
+ Subject => "".$innerletter->{title},
+ Message => "".$innerletter->{content},
+ );
+ sendmail(%mail);
+ &logaction(
+ C4::Context->userenv->{'number'},
+ "ACQUISITION",
+ "CLAIM ISSUE",
+ undef,
+ "To=".$databookseller->{contemail}.
+ " Title=".$innerletter->{title}.
+ " Content=".$innerletter->{content}
+ ) if C4::Context->preference("LetterLog");
+ }
+ warn "sending to From $userenv->{emailaddress} subj $innerletter->{title} Mess $innerletter->{content}";
+ }
}
-=head2
+=head2 parseletter
+
parameters :
- $letter : a hash to letter fields (title & content useful)
- $table : the Koha table to parse.
- $pk : the primary key to query on the $table table
parse all fields from a table, and replace values in title & content with the appropriate value
(not exported sub, used only internally)
+
=cut
+
sub parseletter {
my ($letter,$table,$pk) = @_;
# warn "Parseletter : ($letter,$table,$pk)";
@@ -255,6 +385,8 @@
$sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
} elsif ($table eq 'branches') {
$sth = $dbh->prepare("select * from branches where branchcode=?");
+ } elsif ($table eq 'aqbooksellers') {
+ $sth = $dbh->prepare("select * from aqbooksellers where id=?");
}
$sth->execute($pk);
# store the result in an hash
Index: Log.pm
===================================================================
RCS file: /sources/koha/koha/C4/Log.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- Log.pm 14 Apr 2006 09:33:56 -0000 1.5
+++ Log.pm 9 Mar 2007 14:31:47 -0000 1.6
@@ -29,7 +29,7 @@
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.6 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -50,7 +50,7 @@
=cut
@ISA = qw(Exporter);
- at EXPORT = qw(&logaction &logstatus &displaylog);
+ at EXPORT = qw(&logaction &GetLogStatus &displaylog &GetLogs);
=item logaction
@@ -59,8 +59,9 @@
Adds a record into action_logs table to report the different changes upon the database
=cut
+
#'
-sub logaction{
+sub logaction {
my ($usernumber,$modulename, $actionname, $objectnumber, $infos)=@_;
$usernumber='' unless $usernumber;
my $dbh = C4::Context->dbh;
@@ -69,16 +70,32 @@
$sth->finish;
}
-=item logstatus
+=item GetLogStatus
+
+ $status = GetLogStatus;
- &logstatus;
+C<$status> is a hasref like this example:
+ $hash = {
+ BorrowersLog => 1,
+ CataloguingLog => 0,
+ IssueLog => 0,
+ ...
+ }
-returns True If Activate_Log variable is equal to On
-Activate_Log is a system preference Variable
=cut
+
#'
-sub logstatus{
- return C4::Context->preference("Activate_Log");
+sub GetLogStatus {
+ my %hash;
+ $hash{BorrowersLog} = C4::Context->preference("BorrowersLog");
+ $hash{CataloguingLog} = C4::Context->preference("CataloguingLog");
+ $hash{IssueLog} = C4::Context->preference("IssueLog");
+ $hash{ReturnLog} = C4::Context->preference("CataloguingLog");
+ $hash{SubscriptionLog} = C4::Context->preference("CataloguingLog");
+ $hash{LetterLog} = C4::Context->preference("LetterLog");
+ $hash{FinesLog} = C4::Context->preference("FinesLog");
+
+ return \%hash;
}
=item displaylog
@@ -92,9 +109,10 @@
returns a table of hash containing who did what on which object at what time
=cut
+
#'
-sub displaylog{
- my ($modulename, @filters)=@_;
+sub displaylog {
+ my ($modulename, @filters) = @_;
my $dbh = C4::Context->dbh;
my $strsth;
if ($modulename eq "catalogue"){
@@ -104,16 +122,16 @@
$strsth .= ",biblio " ;#if ($modulename eq "acqui.simple");
$strsth .=" WHERE borrowers.borrowernumber=action_logs.user";
- $strsth .=" AND action_logs.module = 'acqui.simple' AND action_logs.object=biblio.biblionumber ";# if ($modulename eq "acqui.simple");
- if (@filters){
- foreach my $filter (@filters){
- if ($filter->{name} =~ /user/){
+ $strsth .=" AND action_logs.module = 'cataloguing' AND action_logs.object=biblio.biblionumber ";# if ($modulename eq "acqui.simple");
+ if (@filters) {
+ foreach my $filter (@filters) {
+ if ($filter->{name} =~ /user/) {
$filter->{value}=~s/\*/%/g;
$strsth .= " AND borrowers.surname like ".$filter->{value};
- }elsif ($filter->{name} =~ /title/){
+ } elsif ($filter->{name} =~ /title/) {
$filter->{value}=~s/\*/%/g;
$strsth .= " AND biblio.title like ".$filter->{value};
- }elsif ($filter->{name} =~ /author/){
+ } elsif ($filter->{name} =~ /author/) {
$filter->{value}=~s/\*/%/g;
$strsth .= " AND biblio.author like ".$filter->{value};
}
@@ -126,7 +144,7 @@
$strsth .= ",biblio " ;#if ($modulename eq "acqui.simple");
$strsth .=" WHERE borrowers.borrowernumber=action_logs.user";
- $strsth .= "AND action_logs.module = 'acqui.simple' AND action_logs.object=biblio.biblionumber ";# if ($modulename eq "acqui.simple");
+ $strsth .= "AND action_logs.module = 'cataloguing' AND action_logs.object=biblio.biblionumber ";# if ($modulename eq "acqui.simple");
if (@filters){
foreach my $filter (@filters){
if ($filter->{name} =~ /user/){
@@ -166,7 +184,7 @@
}
}
}
-# warn "displaylog :".$strsth;
+
if ($strsth){
my $sth=$dbh->prepare($strsth);
$sth->execute;
@@ -184,6 +202,50 @@
return ($count, \@results);
} else {return 0;}
}
+
+=head2 GetLogs
+
+$logs = GetLogs($datefrom,$dateto,$user,$module,$action,$object,$info);
+
+Return:
+C<$logs> is a ref to a hash which containts all columns from action_logs
+
+=cut
+
+sub GetLogs {
+ my $datefrom = shift;
+ my $dateto = shift;
+ my $user = shift;
+ my $module = shift;
+ my $action = shift;
+ my $object = shift;
+ my $info = shift;
+
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT *
+ FROM action_logs
+ WHERE 1
+ ";
+ $query .= " AND DATE_FORMAT(timestamp, '%Y-%m-%d') >= \"".$datefrom."\" " if $datefrom;
+ $query .= " AND DATE_FORMAT(timestamp, '%Y-%m-%d') <= \"".$dateto."\" " if $dateto;
+ $query .= " AND user LIKE \"%".$user."%\" " if $user;
+ $query .= " AND module LIKE \"%".$module."%\" " if $module;
+ $query .= " AND action LIKE \"%".$action."%\" " if $action;
+ $query .= " AND object LIKE \"%".$object."%\" " if $object;
+ $query .= " AND info LIKE \"%".$info."%\" " if $info;
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+
+ my @logs;
+ while( my $row = $sth->fetchrow_hashref ) {
+ $row->{$row->{module}} = 1;
+ push @logs , $row;
+ }
+ return \@logs;
+}
+
END { } # module clean-up code here (global destructor)
1;
Index: Members.pm
===================================================================
RCS file: /sources/koha/koha/C4/Members.pm,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -b -r1.39 -r1.40
--- Members.pm 6 Nov 2006 21:01:43 -0000 1.39
+++ Members.pm 9 Mar 2007 14:31:47 -0000 1.40
@@ -1,5 +1,3 @@
-# -*- tab-width: 8 -*-
-
package C4::Members;
# Copyright 2000-2003 Katipo Communications
@@ -19,23 +17,19 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Members.pm,v 1.39 2006/11/06 21:01:43 tgarip1957 Exp $
+# $Id: Members.pm,v 1.40 2007/03/09 14:31:47 tipaul Exp $
use strict;
require Exporter;
use C4::Context;
use C4::Date;
use Digest::MD5 qw(md5_base64);
-use C4::Biblio;
-use C4::Stats;
-use C4::Reserves2;
-use C4::Koha;
-use C4::Accounts2;
-use C4::Circulation::Circ2;
+use Date::Calc qw/Today Add_Delta_YM/;
+use C4::Log; # logaction
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = do { my @v = '$Revision: 1.39 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+$VERSION = do { my @v = '$Revision: 1.40 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -55,82 +49,30 @@
=cut
-#'
-
@ISA = qw(Exporter);
@EXPORT = qw(
-
-&allissues
-&add_member_orgs
-&borrdata
-&borrdata2
-&borrdata3
-&BornameSearch
-&borrissues
-&borrowercard_active
-&borrowercategories
-&change_user_pass
-&checkuniquemember
-&calcexpirydate
-&checkuserpassword
-
-ðnicitycategories
-&fixEthnicity
-&fixup_cardnumber
-&findguarantees
-&findguarantor
-&fixupneu_cardnumber
-
-&getmember
-&getMemberPhoto
-&get_institutions
-&getzipnamecity
-&getidcity
-&getguarantordata
-&getcategorytype
-&getboracctrecord
-&getborrowercategory
-&getborrowercategoryinfo
-&get_age
-&getpatroninformation
-&GetBorrowersFromSurname
-&GetBranchCodeFromBorrowers
-&GetFlagsAndBranchFromBorrower
-&GuarantornameSearch
-&NewBorrowerNumber
-&modmember
-&newmember
-&expand_sex_into_predicate
- );
-
-
-
-=head2 borrowercategories
-
- ($codes_arrayref, $labels_hashref) = &borrowercategories();
-
-Looks up the different types of borrowers in the database. Returns two
-elements: a reference-to-array, which lists the borrower category
-codes, and a reference-to-hash, which maps the borrower category codes
-to category descriptions.
-
-=cut
-#'
-
-sub borrowercategories {
- my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select categorycode,description from categories order by description");
- $sth->execute;
- my %labels;
- my @codes;
- while (my $data=$sth->fetchrow_hashref){
- push @codes,$data->{'categorycode'};
- $labels{$data->{'categorycode'}}=$data->{'description'};
- }
- $sth->finish;
- return(\@codes,\%labels);
-}
+ &BornameSearch &GetMember
+ &borrdata &borrdata2
+ &fixup_cardnumber &findguarantees &findguarantor &GuarantornameSearch
+ &modmember &newmember &changepassword &borrissues &allissues
+ &checkuniquemember &getzipnamecity &getidcity &getguarantordata &getcategorytype
+ &DeleteBorrower
+ &calcexpirydate &checkuserpassword
+ &getboracctrecord
+ &GetborCatFromCatType &getborrowercategory
+ &fixEthnicity
+ ðnicitycategories &get_institutions add_member_orgs
+ &get_age &GetBorrowersFromSurname &GetBranchCodeFromBorrowers
+ &GetFlagsAndBranchFromBorrower
+ &GetCities &GetRoadTypes &GetRoadTypeDetails &GetBorNotifyAcctRecord
+ &GetMembeReregistration
+ &GetSortDetails
+ &GetBorrowersTitles
+ &GetBorrowersWhoHaveNotBorrowedSince
+ &GetBorrowersWhoHaveNeverBorrowed
+ &GetBorrowersWithIssuesHistoryOlderThan
+);
=item BornameSearch
@@ -154,199 +96,72 @@
C<$count> is the number of elements in C<$borrowers>.
=cut
+
#'
#used by member enquiries from the intranet
#called by member.pl
sub BornameSearch {
- my ($env,$searchstring,$orderby,$type)=@_;
+ my ( $env, $searchstring, $orderby, $type ) = @_;
my $dbh = C4::Context->dbh;
- my $query = ""; my $count;
+ my $query = "";
+ my $count;
my @data;
- my @bind=();
+ my @bind = ();
- if($type eq "simple") # simple search for one letter only
+ if ( $type eq "simple" ) # simple search for one letter only
{
- $query="Select * from borrowers where surname like '$searchstring%' order by $orderby";
-# @bind=("$searchstring%");
+ $query =
+ "SELECT * FROM borrowers
+ LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
+ WHERE surname LIKE ? ORDER BY $orderby";
+ @bind = ("$searchstring%");
}
else # advanced search looking in surname, firstname and othernames
{
-### Try to determine whether numeric like cardnumber
- if ($searchstring+1>1) {
- $query="Select * from borrowers where cardnumber like '$searchstring%' ";
-
- }else{
-
- my @words=split / /,$searchstring;
- foreach my $word(@words){
- $word="+".$word;
-
- }
- $searchstring=join " ", at words;
-
- $query="Select * from borrowers where MATCH(surname,firstname,othernames) AGAINST('$searchstring' in boolean mode)";
+ @data = split( ' ', $searchstring );
+ $count = @data;
+ $query = "SELECT * FROM borrowers
+ LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
+ WHERE ((surname LIKE ? OR surname LIKE ?
+ OR firstname LIKE ? OR firstname LIKE ?
+ OR othernames LIKE ? OR othernames LIKE ?)
+ ";
+ @bind = (
+ "$data[0]%", "% $data[0]%", "$data[0]%", "% $data[0]%",
+ "$data[0]%", "% $data[0]%"
+ );
+ for ( my $i = 1 ; $i < $count ; $i++ ) {
+ $query = $query . " AND (" . " surname LIKE ? OR surname LIKE ?
+ OR firstname LIKE ? OR firstname LIKE ?
+ OR othernames LIKE ? OR othernames LIKE ?)";
+ push( @bind,
+ "$data[$i]%", "% $data[$i]%", "$data[$i]%",
+ "% $data[$i]%", "$data[$i]%", "% $data[$i]%" );
+ # FIXME - .= <<EOT;
}
- $query=$query." order by $orderby";
- }
+ $query = $query . ") OR cardnumber LIKE ?
+ order by $orderby";
+ push( @bind, $searchstring );
- my $sth=$dbh->prepare($query);
-# warn "Q $orderby : $query";
- $sth->execute();
- my @results;
- my $cnt=$sth->rows;
- while (my $data=$sth->fetchrow_hashref){
- push(@results,$data);
+ # FIXME - .= <<EOT;
}
- # $sth->execute;
- $sth->finish;
- return ($cnt,\@results);
-}
-=head2 getpatroninformation
- ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, $cardnumber);
-Looks up a patron and returns information about him or her. If
-C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
-up the borrower by number; otherwise, it looks up the borrower by card
-number.
-C<$env> is effectively ignored, but should be a reference-to-hash.
-C<$borrower> is a reference-to-hash whose keys are the fields of the
-borrowers table in the Koha database. In addition,
-C<$borrower-E<gt>{flags}> is a hash giving more detailed information
-about the patron. Its keys act as flags :
+ my $sth = $dbh->prepare($query);
- if $borrower->{flags}->{LOST} {
- # Patron's card was reported lost
+ # warn "Q $orderby : $query";
+ $sth->execute(@bind);
+ my @results;
+ my $cnt = $sth->rows;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
}
-Each flag has a C<message> key, giving a human-readable explanation of
-the flag. If the state of a flag means that the patron should not be
-allowed to borrow any more books, then it will have a C<noissues> key
-with a true value.
-
-The possible flags are:
-
-=head3 CHARGES
-
-=over 4
-
-Shows the patron's credit or debt, if any.
-
-=back
-
-=head3 GNA
-
-=over 4
-
-(Gone, no address.) Set if the patron has left without giving a
-forwarding address.
-
-=back
-
-=head3 LOST
-
-=over 4
-
-Set if the patron's card has been reported as lost.
-
-=back
-
-=head3 DBARRED
-
-=over 4
-
-Set if the patron has been debarred.
-
-=back
-
-=head3 NOTES
-
-=over 4
-
-Any additional notes about the patron.
-
-=back
-
-=head3 ODUES
-
-=over 4
-
-Set if the patron has overdue items. This flag has several keys:
-
-C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
-overdue items. Its elements are references-to-hash, each describing an
-overdue item. The keys are selected fields from the issues, biblio,
-biblioitems, and items tables of the Koha database.
-
-C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
-the overdue items, one per line.
-
-=back
-
-=head3 WAITING
-
-=over 4
-
-Set if any items that the patron has reserved are available.
-
-C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
-available items. Each element is a reference-to-hash whose keys are
-fields from the reserves table of the Koha database.
-
-=back
-
-=back
-
-=cut
-
-sub getpatroninformation {
-# returns
- my ($env, $borrowernumber,$cardnumber) = @_;
- my $dbh = C4::Context->dbh;
- my $query;
- my $sth;
- if ($borrowernumber) {
- $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
- $sth->execute($borrowernumber);
- } elsif ($cardnumber) {
- $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
- $sth->execute($cardnumber);
- } else {
- $env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
- return();
- }
- my $borrower = $sth->fetchrow_hashref;
- my $amount = C4::Accounts2::checkaccount($env, $borrowernumber, $dbh);
- $borrower->{'amountoutstanding'} = $amount;
- my $flags = C4::Circulation::Circ2::patronflags($env, $borrower, $dbh);
- my $accessflagshash;
-
- $sth=$dbh->prepare("select bit,flag from userflags");
- $sth->execute;
- while (my ($bit, $flag) = $sth->fetchrow) {
- if ($borrower->{'flags'} & 2**$bit) {
- $accessflagshash->{$flag}=1;
- }
- }
+ # $sth->execute;
$sth->finish;
- $borrower->{'flags'}=$flags;
- $borrower->{'authflags'} = $accessflagshash;
- return ($borrower); #, $flags, $accessflagshash);
+ return ( $cnt, \@results );
}
-=item getmember
-
- $borrower = &getmember($cardnumber, $borrowernumber);
-
-Looks up information about a patron (borrower) by either card number
-or borrower number. If $borrowernumber is specified, C<&borrdata>
-searches by borrower number; otherwise, it searches by card number.
-
-C<&getmember> returns a reference-to-hash whose keys are the fields of
-the C<borrowers> table in the Koha database.
-
-=cut
-
=head3 GetFlagsAndBranchFromBorrower
=over 4
@@ -363,176 +178,6 @@
=cut
-
-
-=item borrissues
-
- ($count, $issues) = &borrissues($borrowernumber);
-
-Looks up what the patron with the given borrowernumber has borrowed.
-
-C<&borrissues> returns a two-element array. C<$issues> is a
-reference-to-array, where each element is a reference-to-hash; the
-keys are the fields from the C<issues>, C<biblio>, and C<items> tables
-in the Koha database. C<$count> is the number of elements in
-C<$issues>.
-
-=cut
-#'
-sub borrissues {
- my ($bornum)=@_;
- my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select * from issues,biblio,items where borrowernumber=?
- and items.itemnumber=issues.itemnumber
- and items.biblionumber=biblio.biblionumber
- and issues.returndate is NULL order by date_due");
- $sth->execute($bornum);
- my @result;
- while (my $data = $sth->fetchrow_hashref) {
- push @result, $data;
- }
- $sth->finish;
- return(scalar(@result), \@result);
-}
-
-=item allissues
-
- ($count, $issues) = &allissues($borrowernumber, $sortkey, $limit);
-
-Looks up what the patron with the given borrowernumber has borrowed,
-and sorts the results.
-
-C<$sortkey> is the name of a field on which to sort the results. This
-should be the name of a field in the C<issues>, C<biblio>,
-C<biblioitems>, or C<items> table in the Koha database.
-
-C<$limit> is the maximum number of results to return.
-
-C<&allissues> returns a two-element array. C<$issues> is a
-reference-to-array, where each element is a reference-to-hash; the
-keys are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
-C<items> tables of the Koha database. C<$count> is the number of
-elements in C<$issues>
-
-=cut
-#'
-sub allissues {
- my ($bornum,$order,$limit)=@_;
- #FIXME: sanity-check order and limit
- my $dbh = C4::Context->dbh;
- my $query="Select * from issues,biblio,items
- where borrowernumber=? and
- items.itemnumber=issues.itemnumber and
- items.biblionumber=biblio.biblionumber order by $order";
- if ($limit !=0){
- $query.=" limit $limit";
- }
- #print $query;
- my $sth=$dbh->prepare($query);
- $sth->execute($bornum);
- my @result;
- my $i=0;
- while (my $data=$sth->fetchrow_hashref){
- $result[$i]=$data;;
- $i++;
- }
- $sth->finish;
- return($i,\@result);
-}
-
-
-sub borrdata3 {
-## NEU specific. used in Reserve section issues
- my ($env,$bornum)=@_;
- my $dbh = C4::Context->dbh;
- my $query="Select count(*) from reserveissue as r where r.borrowernumber='$bornum'
- and rettime is null";
- # print $query;
- my $sth=$dbh->prepare($query);
- $sth->execute;
- my $data=$sth->fetchrow_hashref;
- $sth->finish;
- $sth=$dbh->prepare("Select count(*),timediff(now(), duetime ) as elapsed, hour(timediff(now(), duetime )) as hours, MINUTE(timediff(now(), duetime )) as min from
- reserveissue as r where r.borrowernumber='$bornum' and rettime is null and duetime< now() group by r.borrowernumber");
- $sth->execute;
-
- my $data2=$sth->fetchrow_hashref;
-my $resfine;
-my $rescharge=C4::Context->preference('resmaterialcharge');
- if (!$rescharge){
- $rescharge=1;
- }
- if ($data2->{'elapsed'}>0){
- $resfine=($data2->{'hours'}+$data2->{'min'}/60)*$rescharge;
- $resfine=sprintf ("%.1f",$resfine);
- }
- $sth->finish;
- $sth=$dbh->prepare("Select sum(amountoutstanding) from accountlines where
- borrowernumber='$bornum'");
- $sth->execute;
- my $data3=$sth->fetchrow_hashref;
- $sth->finish;
-
-
-return($data2->{'count(*)'},$data->{'count(*)'},$data3->{'sum(amountoutstanding)'},$resfine);
-}
-=item getboracctrecord
-
- ($count, $acctlines, $total) = &getboracctrecord($env, $borrowernumber);
-
-Looks up accounting data for the patron with the given borrowernumber.
-
-C<$env> is ignored.
-
-
-C<&getboracctrecord> returns a three-element array. C<$acctlines> is a
-reference-to-array, where each element is a reference-to-hash; the
-keys are the fields of the C<accountlines> table in the Koha database.
-C<$count> is the number of elements in C<$acctlines>. C<$total> is the
-total amount outstanding for all of the account lines.
-
-=cut
-#'
-sub getboracctrecord {
- my ($env,$params) = @_;
- my $dbh = C4::Context->dbh;
- my @acctlines;
- my $numlines=0;
- my $sth=$dbh->prepare("Select * from accountlines where
-borrowernumber=? order by date desc,timestamp desc");
-# print $query;
- $sth->execute($params->{'borrowernumber'});
- my $total=0;
- while (my $data=$sth->fetchrow_hashref){
- $acctlines[$numlines] = $data;
- $numlines++;
- $total += $data->{'amountoutstanding'};
- }
- $sth->finish;
- return ($numlines,\@acctlines,$total);
-}
-
-sub getborrowercategory{
- my ($catcode) = @_;
- my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT description FROM categories WHERE categorycode = ?");
- $sth->execute($catcode);
- my $description = $sth->fetchrow();
- $sth->finish();
- return $description;
-} # sub getborrowercategory
-
-sub getborrowercategoryinfo{
- my ($catcode) = @_;
- my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT * FROM categories WHERE categorycode = ?");
- $sth->execute($catcode);
- my $category = $sth->fetchrow_hashref;
- $sth->finish();
- return $category;
-} # sub getborrowercategoryinfo
-
-
sub GetFlagsAndBranchFromBorrower {
my $loggedinuser = @_;
my $dbh = C4::Context->dbh;
@@ -547,18 +192,31 @@
return $sth->fetchrow;
}
+=item GetMember
-sub getmember {
- my ( $cardnumber, $bornum ) = @_;
+ $borrower = &GetMember($cardnumber, $borrowernumber);
+
+Looks up information about a patron (borrower) by either card number
+or borrower number. If $borrowernumber is specified, C<&borrdata>
+searches by borrower number; otherwise, it searches by card number.
+
+C<&GetMember> returns a reference-to-hash whose keys are the fields of
+the C<borrowers> table in the Koha database.
+
+=cut
+
+sub GetMember {
+ my ( $cardnumber, $borrowernumber ) = @_;
$cardnumber = uc $cardnumber;
my $dbh = C4::Context->dbh;
my $sth;
- if ( $bornum eq '' ) {
+ if ( $borrowernumber eq '' ) {
$sth = $dbh->prepare("Select * from borrowers where cardnumber=?");
$sth->execute($cardnumber);
- } else {
+ }
+ else {
$sth = $dbh->prepare("Select * from borrowers where borrowernumber=?");
- $sth->execute($bornum);
+ $sth->execute($borrowernumber);
}
my $data = $sth->fetchrow_hashref;
$sth->finish;
@@ -593,11 +251,11 @@
#'
sub borrdata {
- my ( $cardnumber, $bornum ) = @_;
+ my ( $cardnumber, $borrowernumber ) = @_;
$cardnumber = uc $cardnumber;
my $dbh = C4::Context->dbh;
my $sth;
- if ( $bornum eq '' ) {
+ if ( $borrowernumber eq '' ) {
$sth =
$dbh->prepare(
"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where cardnumber=?"
@@ -609,16 +267,15 @@
$dbh->prepare(
"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where borrowernumber=?"
);
- $sth->execute($bornum);
+ $sth->execute($borrowernumber);
}
my $data = $sth->fetchrow_hashref;
-# warn "DATA" . $data->{category_type};
+
$sth->finish;
if ($data) {
return ($data);
}
- else { # try with firstname
- if ($cardnumber) {
+ elsif ($cardnumber) { # try with firstname
my $sth =
$dbh->prepare(
"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where firstname=?"
@@ -628,8 +285,9 @@
$sth->finish;
return ($data);
}
- }
+ else {
return undef;
+ }
}
=item borrdata2
@@ -650,9 +308,10 @@
#'
sub borrdata2 {
- my ( $env, $bornum ) = @_;
+ my ( $env, $borrowernumber ) = @_;
my $dbh = C4::Context->dbh;
- my $query = "Select count(*) from issues where borrowernumber='$bornum' and
+ my $query =
+ "Select count(*) from issues where borrowernumber='$borrowernumber' and
returndate is NULL";
# print $query;
@@ -662,14 +321,14 @@
$sth->finish;
$sth = $dbh->prepare(
"Select count(*) from issues where
- borrowernumber='$bornum' and date_due < now() and returndate is NULL"
+ borrowernumber='$borrowernumber' and date_due < now() and returndate is NULL"
);
$sth->execute;
my $data2 = $sth->fetchrow_hashref;
$sth->finish;
$sth = $dbh->prepare(
"Select sum(amountoutstanding) from accountlines where
- borrowernumber='$bornum'"
+ borrowernumber='$borrowernumber'"
);
$sth->execute;
my $data3 = $sth->fetchrow_hashref;
@@ -682,188 +341,254 @@
sub modmember {
my (%data) = @_;
my $dbh = C4::Context->dbh;
- $data{'dateofbirth'}=format_date_in_iso($data{'dateofbirth'});
+ $data{'dateofbirth'} = format_date_in_iso( $data{'dateofbirth'} );
+ $data{'dateexpiry'} = format_date_in_iso( $data{'dateexpiry'} );
+ $data{'dateenrolled'} = format_date_in_iso( $data{'dateenrolled'} );
+ # warn "num user".$data{'borrowernumber'};
+ my $query;
+ my $sth;
+ $data{'userid'} = '' if ( $data{'password'} eq '' );
- $data{'joining'}=format_date_in_iso($data{'joining'});
-
- if ($data{'expiry'}) {
- $data{'expiry'}=format_date_in_iso($data{'expiry'});
- }else{
-
- $data{'expiry'} = calcexpirydate($data{'categorycode'},$data{'joining'} );
+ # test to know if u must update or not the borrower password
+ if ( $data{'password'} eq '****' ) {
+ $query = "UPDATE borrowers SET
+ cardnumber = ?,surname = ?,firstname = ?,title = ?,othernames = ?,initials = ?,
+ streetnumber = ?,streettype = ?,address = ?,address2 = ?,city = ?,zipcode = ?,
+ email = ?,phone = ?,mobile = ?,fax = ?,emailpro = ?,phonepro = ?,B_streetnumber = ?,
+ B_streettype = ?,B_address = ?,B_city = ?,B_zipcode = ?,B_email = ?,B_phone = ?,dateofbirth = ?,branchcode = ?,
+ categorycode = ?,dateenrolled = ?,dateexpiry = ?,gonenoaddress = ?,lost = ?,debarred = ?,contactname = ?,
+ contactfirstname = ?,contacttitle = ?,guarantorid = ?,borrowernotes = ?,relationship = ?,ethnicity = ?,
+ ethnotes = ?,sex = ?,userid = ?,opacnote = ?,contactnote = ?,sort1 = ?,sort2 = ?
+ WHERE borrowernumber=$data{'borrowernumber'}";
+ $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data{'cardnumber'}, $data{'surname'},
+ $data{'firstname'}, $data{'title'},
+ $data{'othernames'}, $data{'initials'},
+ $data{'streetnumber'}, $data{'streettype'},
+ $data{'address'}, $data{'address2'},
+ $data{'city'}, $data{'zipcode'},
+ $data{'email'}, $data{'phone'},
+ $data{'mobile'}, $data{'fax'},
+ $data{'emailpro'}, $data{'phonepro'},
+ $data{'B_streetnumber'}, $data{'B_streettype'},
+ $data{'B_address'}, $data{'B_city'},
+ $data{'B_zipcode'}, $data{'B_email'},
+ $data{'B_phone'}, $data{'dateofbirth'},
+ $data{'branchcode'}, $data{'categorycode'},
+ $data{'dateenrolled'}, $data{'dateexpiry'},
+ $data{'gonenoaddress'}, $data{'lost'},
+ $data{'debarred'}, $data{'contactname'},
+ $data{'contactfirstname'}, $data{'contacttitle'},
+ $data{'guarantorid'}, $data{'borrowernotes'},
+ $data{'relationship'}, $data{'ethnicity'},
+ $data{'ethnotes'}, $data{'sex'},
+ $data{'userid'}, $data{'opacnote'},
+ $data{'contactnote'}, $data{'sort1'},
+ $data{'sort2'}
+ );
}
+ else {
- my $query= "UPDATE borrowers SET
- cardnumber = '$data{'cardnumber'}' ,
- surname = '$data{'surname'}' ,
- firstname = '$data{'firstname'}' ,
- title = '$data{'title'}' ,
- initials = '$data{'initials'}' ,
- dateofbirth = '$data{'dateofbirth'}' ,
- sex = '$data{'sex'}' ,
- streetaddress = '$data{'streetaddress'}' ,
- streetcity = '$data{'streetcity'}' ,
- zipcode = '$data{'zipcode'}' ,
- phoneday = '$data{'phoneday'}' ,
- physstreet = '$data{'physstreet'}' ,
- city = '$data{'city'}' ,
- homezipcode = '$data{'homezipcode'}' ,
- phone = '$data{'phone'}' ,
- emailaddress = '$data{'emailaddress'}' ,
- preferredcont = '$data{'preferredcont'}',
- faxnumber = '$data{'faxnumber'}' ,
- textmessaging = '$data{'textmessaging'}' ,
- categorycode = '$data{'categorycode'}' ,
- branchcode = '$data{'branchcode'}' ,
- borrowernotes = '$data{'borrowernotes'}' ,
- ethnicity = '$data{'ethnicity'}' ,
- ethnotes = '$data{'ethnotes'}' ,
- expiry = '$data{'expiry'}' ,
- dateenrolled = '$data{'joining'}' ,
- sort1 = '$data{'sort1'}' ,
- sort2 = '$data{'sort2'}' ,
- debarred = '$data{'debarred'}' ,
- lost = '$data{'lost'}' ,
- gonenoaddress = '$data{'gna'}'
- WHERE borrowernumber = $data{'borrowernumber'}";
- my $sth = $dbh->prepare($query);
- $sth->execute;
+ ( $data{'password'} = md5_base64( $data{'password'} ) )
+ if ( $data{'password'} ne '' );
+ $query = "UPDATE borrowers SET
+ cardnumber = ?,surname = ?,firstname = ?,title = ?,othernames = ?,initials = ?,
+ streetnumber = ?,streettype = ?,address = ?,address2 = ?,city = ?,zipcode = ?,
+ email = ?,phone = ?,mobile = ?,fax = ?,emailpro = ?,phonepro = ?,B_streetnumber = ?,
+ B_streettype = ?,B_address = ?,B_city = ?,B_zipcode = ?,B_email = ?,B_phone = ?,dateofbirth = ?,branchcode = ?,
+ categorycode = ?,dateenrolled = ?,dateexpiry = ?,gonenoaddress = ?,lost = ?,debarred = ?,contactname = ?,
+ contactfirstname = ?,contacttitle = ?,guarantorid = ?,borrowernotes = ?,relationship = ?,ethnicity = ?,
+ ethnotes = ?,sex = ?,password = ?,userid = ?,opacnote = ?,contactnote = ?,sort1 = ?,sort2 = ?
+ WHERE borrowernumber=$data{'borrowernumber'}";
+ $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data{'cardnumber'}, $data{'surname'},
+ $data{'firstname'}, $data{'title'},
+ $data{'othernames'}, $data{'initials'},
+ $data{'streetnumber'}, $data{'streettype'},
+ $data{'address'}, $data{'address2'},
+ $data{'city'}, $data{'zipcode'},
+ $data{'email'}, $data{'phone'},
+ $data{'mobile'}, $data{'fax'},
+ $data{'emailpro'}, $data{'phonepro'},
+ $data{'B_streetnumber'}, $data{'B_streettype'},
+ $data{'B_address'}, $data{'B_city'},
+ $data{'B_zipcode'}, $data{'B_email'},
+ $data{'B_phone'}, $data{'dateofbirth'},
+ $data{'branchcode'}, $data{'categorycode'},
+ $data{'dateenrolled'}, $data{'dateexpiry'},
+ $data{'gonenoaddress'}, $data{'lost'},
+ $data{'debarred'}, $data{'contactname'},
+ $data{'contactfirstname'}, $data{'contacttitle'},
+ $data{'guarantorid'}, $data{'borrowernotes'},
+ $data{'relationship'}, $data{'ethnicity'},
+ $data{'ethnotes'}, $data{'sex'},
+ $data{'password'}, $data{'userid'},
+ $data{'opacnote'}, $data{'contactnote'},
+ $data{'sort1'}, $data{'sort2'}
+ );
+ }
$sth->finish;
- # ok if its an adult (type) it may have borrowers that depend on it as a guarantor
- # so when we update information for an adult we should check for guarantees and update the relevant part
- # of their records, ie addresses and phone numbers
- if ($data{'categorycode'} eq 'A' || $data{'categorycode'} eq 'W'){
+
+# ok if its an adult (type) it may have borrowers that depend on it as a guarantor
+# so when we update information for an adult we should check for guarantees and update the relevant part
+# of their records, ie addresses and phone numbers
+ my ( $category_type, undef ) = getcategorytype( $data{'category_type'} );
+ if ( $category_type eq 'A' ) {
+
# is adult check guarantees;
updateguarantees(%data);
+
}
+ &logaction(C4::Context->userenv->{'number'},"MEMBERS","MODIFY",$data{'borrowernumber'},"")
+ if C4::Context->preference("BorrowersLog");
}
sub newmember {
my (%data) = @_;
my $dbh = C4::Context->dbh;
- $data{'dateofbirth'}=format_date_in_iso($data{'dateofbirth'});
-
+ $data{'userid'} = '' unless $data{'password'};
+ $data{'password'} = md5_base64( $data{'password'} ) if $data{'password'};
+ $data{'dateofbirth'} = format_date_in_iso( $data{'dateofbirth'} );
+ $data{'dateenrolled'} = format_date_in_iso( $data{'dateenrolled'} );
+ $data{'dateexpiry'} = format_date_in_iso( $data{'dateexpiry'} );
+ my $query =
+ "insert into borrowers set cardnumber="
+ . $dbh->quote( $data{'cardnumber'} )
+ . ",surname="
+ . $dbh->quote( $data{'surname'} )
+ . ",firstname="
+ . $dbh->quote( $data{'firstname'} )
+ . ",title="
+ . $dbh->quote( $data{'title'} )
+ . ",othernames="
+ . $dbh->quote( $data{'othernames'} )
+ . ",initials="
+ . $dbh->quote( $data{'initials'} )
+ . ",streetnumber="
+ . $dbh->quote( $data{'streetnumber'} )
+ . ",streettype="
+ . $dbh->quote( $data{'streettype'} )
+ . ",address="
+ . $dbh->quote( $data{'address'} )
+ . ",address2="
+ . $dbh->quote( $data{'address2'} )
+ . ",zipcode="
+ . $dbh->quote( $data{'zipcode'} )
+ . ",city="
+ . $dbh->quote( $data{'city'} )
+ . ",phone="
+ . $dbh->quote( $data{'phone'} )
+ . ",email="
+ . $dbh->quote( $data{'email'} )
+ . ",mobile="
+ . $dbh->quote( $data{'mobile'} )
+ . ",phonepro="
+ . $dbh->quote( $data{'phonepro'} )
+ . ",opacnote="
+ . $dbh->quote( $data{'opacnote'} )
+ . ",guarantorid="
+ . $dbh->quote( $data{'guarantorid'} )
+ . ",dateofbirth="
+ . $dbh->quote( $data{'dateofbirth'} )
+ . ",branchcode="
+ . $dbh->quote( $data{'branchcode'} )
+ . ",categorycode="
+ . $dbh->quote( $data{'categorycode'} )
+ . ",dateenrolled="
+ . $dbh->quote( $data{'dateenrolled'} )
+ . ",contactname="
+ . $dbh->quote( $data{'contactname'} )
+ . ",borrowernotes="
+ . $dbh->quote( $data{'borrowernotes'} )
+ . ",dateexpiry="
+ . $dbh->quote( $data{'dateexpiry'} )
+ . ",contactnote="
+ . $dbh->quote( $data{'contactnote'} )
+ . ",B_address="
+ . $dbh->quote( $data{'B_address'} )
+ . ",B_zipcode="
+ . $dbh->quote( $data{'B_zipcode'} )
+ . ",B_city="
+ . $dbh->quote( $data{'B_city'} )
+ . ",B_phone="
+ . $dbh->quote( $data{'B_phone'} )
+ . ",B_email="
+ . $dbh->quote( $data{'B_email'}, )
+ . ",password="
+ . $dbh->quote( $data{'password'} )
+ . ",userid="
+ . $dbh->quote( $data{'userid'} )
+ . ",sort1="
+ . $dbh->quote( $data{'sort1'} )
+ . ",sort2="
+ . $dbh->quote( $data{'sort2'} )
+ . ",contacttitle="
+ . $dbh->quote( $data{'contacttitle'} )
+ . ",emailpro="
+ . $dbh->quote( $data{'emailpro'} )
+ . ",contactfirstname="
+ . $dbh->quote( $data{'contactfirstname'} ) . ",sex="
+ . $dbh->quote( $data{'sex'} ) . ",fax="
+ . $dbh->quote( $data{'fax'} )
+ . ",relationship="
+ . $dbh->quote( $data{'relationship'} )
+ . ",B_streetnumber="
+ . $dbh->quote( $data{'B_streetnumber'} )
+ . ",B_streettype="
+ . $dbh->quote( $data{'B_streettype'} )
+ . ",gonenoaddress="
+ . $dbh->quote( $data{'gonenoaddress'} )
+ . ",lost="
+ . $dbh->quote( $data{'lost'} )
+ . ",debarred="
+ . $dbh->quote( $data{'debarred'} )
+ . ",ethnicity="
+ . $dbh->quote( $data{'ethnicity'} )
+ . ",ethnotes="
+ . $dbh->quote( $data{'ethnotes'} );
- if ($data{'joining'}){
- $data{'joining'}=format_date_in_iso($data{'joining'});
- }else{
- $data{'joining'} = get_today();
- }
- # if expirydate is not set, calculate it from borrower category subscription duration
- if ($data{'expiry'}) {
- $data{'expiry'}=format_date_in_iso($data{'expiry'});
- }else{
-
- $data{'expiry'} = calcexpirydate($data{'categorycode'},$data{'joining'});
- }
-
- my $query= "INSERT INTO borrowers (
- cardnumber,
- surname,
- firstname,
- title,
- initials,
- dateofbirth,
- sex,
- streetaddress,
- streetcity,
- zipcode,
- phoneday,
- physstreet,
- city,
- homezipcode,
- phone,
- emailaddress,
- faxnumber,
- textmessaging,
- preferredcont,
- categorycode,
- branchcode,
- borrowernotes,
- ethnicity,
- ethnotes,
- expiry,
- dateenrolled,
- sort1,
- sort2
- )
- VALUES (
- '$data{'cardnumber'}',
- '$data{'surname'}',
- '$data{'firstname'}',
- '$data{'title'}',
- '$data{'initials'}',
- '$data{'dateofbirth'}',
- '$data{'sex'}',
-
- '$data{'streetaddress'}',
- '$data{'streetcity'}',
- '$data{'zipcode'}',
- '$data{'phoneday'}',
-
- '$data{'physstreet'}',
- '$data{'city'}',
- '$data{'homezipcode'}',
- '$data{'phone'}',
-
- '$data{'emailaddress'}',
- '$data{'faxnumber'}',
- '$data{'textmessaging'}',
- '$data{'preferredcont'}',
- '$data{'categorycode'}',
- '$data{'branchcode'}',
- '$data{'borrowernotes'}',
- '$data{'ethnicity'}',
- '$data{'ethnotes'}',
- '$data{'expiry'}',
- '$data{'joining'}',
- '$data{'sort1'}',
- '$data{'sort2'}'
- )";
- my $sth=$dbh->prepare($query);
+ my $sth = $dbh->prepare($query);
$sth->execute;
$sth->finish;
- $data{'bornum'} =$dbh->{'mysql_insertid'};
- return $data{'bornum'};
-}
+ $data{'borrowernumber'} = $dbh->{'mysql_insertid'};
-sub calcexpirydate {
- my ( $categorycode, $dateenrolled ) = @_;
- my $dbh = C4::Context->dbh;
- my $sth =
- $dbh->prepare(
- "select enrolmentperiod from categories where categorycode=?");
- $sth->execute($categorycode);
- my ($enrolmentperiod) = $sth->fetchrow;
-$enrolmentperiod = 1 unless ($enrolmentperiod);#enrolmentperiod in years
- my $duration=get_duration($enrolmentperiod." years");
- return DATE_Add_Duration($dateenrolled,$duration);
+ &logaction(C4::Context->userenv->{'number'},"MEMBERS","CREATE",$data{'borrowernumber'},"")
+ if C4::Context->preference("BorrowersLog");
+ return $data{'borrowernumber'};
}
-=head2 checkuserpassword (OUEST-PROVENCE)
-
-check for the password and login are not used
-return the number of record
-0=> NOT USED 1=> USED
-
-=cut
-
-sub checkuserpassword {
- my ( $borrowernumber, $userid, $password ) = @_;
- $password = md5_base64($password);
+sub changepassword {
+ my ( $uid, $member, $digest ) = @_;
my $dbh = C4::Context->dbh;
+
+#Make sure the userid chosen is unique and not theirs if non-empty. If it is not,
+#Then we need to tell the user and have them create a new one.
my $sth =
$dbh->prepare(
-"Select count(*) from borrowers where borrowernumber !=? and userid =? and password=? "
- );
- $sth->execute( $borrowernumber, $userid, $password );
- my $number_rows = $sth->fetchrow;
- return $number_rows;
+ "select * from borrowers where userid=? and borrowernumber != ?");
+ $sth->execute( $uid, $member );
+ if ( ( $uid ne '' ) && ( $sth->fetchrow ) ) {
+ return 0;
+ }
+ else {
+ #Everything is good so we can update the information.
+ $sth =
+ $dbh->prepare(
+ "update borrowers set userid=?, password=? where borrowernumber=?");
+ $sth->execute( $uid, $digest, $member );
+ return 1;
+ }
+
+ &logaction(C4::Context->userenv->{'number'},"MEMBERS","CHANGE PASS",$member,"")
+ if C4::Context->preference("BorrowersLog");
}
+
sub getmemberfromuserid {
my ($userid) = @_;
my $dbh = C4::Context->dbh;
@@ -871,6 +596,7 @@
$sth->execute($userid);
return $sth->fetchrow_hashref;
}
+
sub updateguarantees {
my (%data) = @_;
my $dbh = C4::Context->dbh;
@@ -881,17 +607,16 @@
# It looks like the $i is only being returned to handle walking through
# the array, which is probably better done as a foreach loop.
#
- my $guaquery =
-"update borrowers set streetaddress='$data{'address'}',faxnumber='$data{'faxnumber'}',
- streetcity='$data{'streetcity'}',phoneday='$data{'phoneday'}',city='$data{'city'}',area='$data{'area'}',phone='$data{'phone'}'
- ,streetaddress='$data{'address'}'
- where borrowernumber='$guarantees->[$i]->{'borrowernumber'}'";
+ my $guaquery = qq|UPDATE borrowers
+ SET address='$data{'address'}',fax='$data{'fax'}',
+ B_city='$data{'B_city'}',mobile='$data{'mobile'}',city='$data{'city'}',phone='$data{'phone'}'
+ WHERE borrowernumber='$guarantees->[$i]->{'borrowernumber'}'
+ |;
my $sth3 = $dbh->prepare($guaquery);
$sth3->execute;
$sth3->finish;
}
}
-################################################################################
=item fixup_cardnumber
@@ -907,7 +632,7 @@
my ($cardnumber) = @_;
my $autonumber_members = C4::Context->boolean_preference('autoMemberNum');
$autonumber_members = 0 unless defined $autonumber_members;
-my $rem;
+
# Find out whether member numbers should be generated
# automatically. Should be either "1" or something else.
# Defaults to "0", which is interpreted as "no".
@@ -932,10 +657,10 @@
my $data = $sth->fetchrow_hashref;
$cardnumber = $data->{'max(substring(borrowers.cardnumber,2,7))'};
$sth->finish;
-
if ( !$cardnumber ) { # If DB has no values,
$cardnumber = 1000000; # start at 1000000
- } else {
+ }
+ else {
$cardnumber += 1;
}
@@ -952,7 +677,7 @@
$sum += $temp1 * $temp2;
}
- $rem = ( $sum % 11 );
+ my $rem = ( $sum % 11 );
$rem = 'X' if $rem == 10;
$cardnumber = "V$cardnumber$rem";
@@ -969,61 +694,78 @@
$sth->execute;
- $cardnumber="V$cardnumber$rem";
+ my ($result) = $sth->fetchrow;
+ $sth->finish;
+ $cardnumber = $result + 1;
+ }
}
return $cardnumber;
}
-}
-sub fixupneu_cardnumber{
- my($cardnumber,$categorycode) = @_;
- my $autonumber_members = C4::Context->boolean_preference('autoMemberNum');
- $autonumber_members = 0 unless defined $autonumber_members;
- # Find out whether member numbers should be generated
- # automatically. Should be either "1" or something else.
- # Defaults to "0", which is interpreted as "no".
-my $dbh = C4::Context->dbh;
-my $sth;
- if (!$cardnumber && $autonumber_members && $categorycode) {
- if ($categorycode eq "A" || $categorycode eq "W" ){
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '5%' ");
- }elsif ($categorycode eq "L"){
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '10%' ");
- }elsif ($categorycode eq "F" || $categorycode eq "E") {
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '30%' ");
- }elsif ($categorycode eq "N"){
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '40%' ");
- }elsif ($categorycode eq "C"){
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '80%' ");
- }else{
- $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers where borrowers.cardnumber like '6%' ");
- }
- $sth->execute;
+=head2 findguarantees
- my $data=$sth->fetchrow_hashref;
- $cardnumber=$data->{'max(borrowers.cardnumber)'};
- $sth->finish;
+ ($num_children, $children_arrayref) = &findguarantees($parent_borrno);
+ $child0_cardno = $children_arrayref->[0]{"cardnumber"};
+ $child0_borrno = $children_arrayref->[0]{"borrowernumber"};
- # purpose: generate checksum'd member numbers.
- # We'll assume we just got the max value of digits 2-8 of member #'s
- # from the database and our job is to increment that by one,
- # determine the 1st and 9th digits and return the full string.
+C<&findguarantees> takes a borrower number (e.g., that of a patron
+with children) and looks up the borrowers who are guaranteed by that
+borrower (i.e., the patron's children).
- if (! $cardnumber) { # If DB has no values,
- if ($categorycode eq "A" || $categorycode eq "W" ){ $cardnumber = 5000000;}
- elsif ($categorycode eq "L"){ $cardnumber = 1000000;}
- elsif ($categorycode eq "F"){ $cardnumber = 3000000;}
- elsif ($categorycode eq "C"){ $cardnumber = 8000000;}
- elsif ($categorycode eq "N"){ $cardnumber = 4000000;}
- else{$cardnumber = 6000000;}
- # start at 1000000 or 3000000 or 5000000
- } else {
- $cardnumber += 1;
- }
+C<&findguarantees> returns two values: an integer giving the number of
+borrowers guaranteed by C<$parent_borrno>, and a reference to an array
+of references to hash, which gives the actual results.
+
+=cut
+#'
+sub findguarantees {
+ my ($borrowernumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"select cardnumber,borrowernumber, firstname, surname from borrowers where guarantorid=?"
+ );
+ $sth->execute($borrowernumber);
+ my @dat;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @dat, $data;
}
- return $cardnumber;
+ $sth->finish;
+ return ( scalar(@dat), \@dat );
+}
+
+=head2 findguarantor
+
+ $guarantor = &findguarantor($borrower_no);
+ $guarantor_cardno = $guarantor->{"cardnumber"};
+ $guarantor_surname = $guarantor->{"surname"};
+ ...
+
+C<&findguarantor> takes a borrower number (presumably that of a child
+patron), finds the guarantor for C<$borrower_no> (the child's parent),
+and returns the record for the guarantor.
+
+C<&findguarantor> returns a reference-to-hash. Its keys are the fields
+from the C<borrowers> database table;
+
+=cut
+
+#'
+sub findguarantor {
+ my ($borrowernumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare("select guarantorid from borrowers where borrowernumber=?");
+ $sth->execute($borrowernumber);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ $sth = $dbh->prepare("Select * from borrowers where borrowernumber=?");
+ $sth->execute( $data->{'guarantorid'} );
+ $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return ($data);
}
=item GuarantornameSearch
@@ -1111,113 +853,210 @@
return ( $cnt, \@results );
}
+=head2 borrissues
-=item findguarantees
-
- ($num_children, $children_arrayref) = &findguarantees($parent_borrno);
- $child0_cardno = $children_arrayref->[0]{"cardnumber"};
- $child0_borrno = $children_arrayref->[0]{"borrowernumber"};
+ ($count, $issues) = &borrissues($borrowernumber);
-C<&findguarantees> takes a borrower number (e.g., that of a patron
-with children) and looks up the borrowers who are guaranteed by that
-borrower (i.e., the patron's children).
+Looks up what the patron with the given borrowernumber has borrowed.
-C<&findguarantees> returns two values: an integer giving the number of
-borrowers guaranteed by C<$parent_borrno>, and a reference to an array
-of references to hash, which gives the actual results.
+C<&borrissues> returns a two-element array. C<$issues> is a
+reference-to-array, where each element is a reference-to-hash; the
+keys are the fields from the C<issues>, C<biblio>, and C<items> tables
+in the Koha database. C<$count> is the number of elements in
+C<$issues>.
=cut
+
#'
-sub findguarantees{
- my ($bornum)=@_;
+sub borrissues {
+ my ($borrowernumber) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select cardnumber,borrowernumber, firstname, surname from borrowers where guarantor=?");
- $sth->execute($bornum);
-
- my @dat;
- while (my $data = $sth->fetchrow_hashref)
- {
- push @dat, $data;
+ my $sth = $dbh->prepare(
+ "Select * from issues,biblio,items where borrowernumber=?
+ and items.itemnumber=issues.itemnumber
+ and items.biblionumber=biblio.biblionumber
+ and issues.returndate is NULL order by date_due"
+ );
+ $sth->execute($borrowernumber);
+ my @result;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @result, $data;
}
$sth->finish;
- return (scalar(@dat), \@dat);
+ return ( scalar(@result), \@result );
}
-=item findguarantor
+=head2 allissues
- $guarantor = &findguarantor($borrower_no);
- $guarantor_cardno = $guarantor->{"cardnumber"};
- $guarantor_surname = $guarantor->{"surname"};
- ...
+ ($count, $issues) = &allissues($borrowernumber, $sortkey, $limit);
-C<&findguarantor> takes a borrower number (presumably that of a child
-patron), finds the guarantor for C<$borrower_no> (the child's parent),
-and returns the record for the guarantor.
+Looks up what the patron with the given borrowernumber has borrowed,
+and sorts the results.
-C<&findguarantor> returns a reference-to-hash. Its keys are the fields
-from the C<borrowers> database table;
+C<$sortkey> is the name of a field on which to sort the results. This
+should be the name of a field in the C<issues>, C<biblio>,
+C<biblioitems>, or C<items> table in the Koha database.
+
+C<$limit> is the maximum number of results to return.
+
+C<&allissues> returns a two-element array. C<$issues> is a
+reference-to-array, where each element is a reference-to-hash; the
+keys are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
+C<items> tables of the Koha database. C<$count> is the number of
+elements in C<$issues>
=cut
+
#'
-sub findguarantor{
- my ($bornum)=@_;
+sub allissues {
+ my ( $borrowernumber, $order, $limit ) = @_;
+
+ #FIXME: sanity-check order and limit
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select guarantor from borrowers where borrowernumber=?");
- $sth->execute($bornum);
- my $data=$sth->fetchrow_hashref;
- $sth->finish;
- $sth=$dbh->prepare("Select * from borrowers where borrowernumber=?");
- $sth->execute($data->{'guarantor'});
- $data=$sth->fetchrow_hashref;
+ my $count = 0;
+ my $query =
+"Select *,items.timestamp AS itemstimestamp from issues,biblio,items,biblioitems
+ where borrowernumber=? and
+ items.biblioitemnumber=biblioitems.biblioitemnumber and
+ items.itemnumber=issues.itemnumber and
+ items.biblionumber=biblio.biblionumber order by $order";
+ if ( $limit != 0 ) {
+ $query .= " limit $limit";
+ }
+
+ #print $query;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber);
+ my @result;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $result[$i] = $data;
+ $i++;
+ $count++;
+ }
+
+ # get all issued items for borrowernumber from oldissues table
+ # large chunk of older issues data put into table oldissues
+ # to speed up db calls for issuing items
+ if ( C4::Context->preference("ReadingHistory") ) {
+ my $query2 = "SELECT * FROM oldissues,biblio,items,biblioitems
+ WHERE borrowernumber=?
+ AND items.biblioitemnumber=biblioitems.biblioitemnumber
+ AND items.itemnumber=oldissues.itemnumber
+ AND items.biblionumber=biblio.biblionumber
+ ORDER BY $order";
+ if ( $limit != 0 ) {
+ $limit = $limit - $count;
+ $query2 .= " limit $limit";
+ }
+
+ my $sth2 = $dbh->prepare($query2);
+ $sth2->execute($borrowernumber);
+
+ while ( my $data2 = $sth2->fetchrow_hashref ) {
+ $result[$i] = $data2;
+ $i++;
+ }
+ $sth2->finish;
+ }
$sth->finish;
- return($data);
+
+ return ( $i, \@result );
}
-sub borrowercard_active {
- my ($bornum) = @_;
+=head2 getboracctrecord
+
+ ($count, $acctlines, $total) = &getboracctrecord($env, $borrowernumber);
+
+Looks up accounting data for the patron with the given borrowernumber.
+
+C<$env> is ignored.
+
+(FIXME - I'm not at all sure what this is about.)
+
+C<&getboracctrecord> returns a three-element array. C<$acctlines> is a
+reference-to-array, where each element is a reference-to-hash; the
+keys are the fields of the C<accountlines> table in the Koha database.
+C<$count> is the number of elements in C<$acctlines>. C<$total> is the
+total amount outstanding for all of the account lines.
+
+=cut
+
+#'
+sub getboracctrecord {
+ my ( $env, $params ) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT expiry FROM borrowers WHERE (borrowernumber = ?) AND (NOW() <= expiry)");
- $sth->execute($bornum);
- if (my $data=$sth->fetchrow_hashref){
- return ('1');
- }else{
- return ('0');
- }
-}
+ my @acctlines;
+ my $numlines = 0;
+ my $sth = $dbh->prepare(
+ "Select * from accountlines where
+borrowernumber=? order by date desc,timestamp desc"
+ );
-# Search the member photo, in case that photo doesn´t exists, return a default photo.for NEU
-sub getMemberPhoto {
- my $cardnumber = shift @_;
- my $htdocs = C4::Context->config('opacdir');
-my $dirname = $htdocs."/htdocs/uploaded-files/users-photo/";
-# my $dirname = "$ENV{'DOCUMENT_ROOT'}/uploaded-files/users-photo";
- opendir(DIR, $dirname) or die "Can't open directory $dirname: $!";
- while (defined(my $file = readdir(DIR))) {
- if ($file =~ /^$cardnumber\..+/){
- return "/uploaded-files/users-photo/$file";
- }
+ $sth->execute( $params->{'borrowernumber'} );
+ my $total = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ #FIXME before reinstating: insecure?
+ # if ($data->{'itemnumber'} ne ''){
+ # $query="Select * from items,biblio where items.itemnumber=
+ # '$data->{'itemnumber'}' and biblio.biblionumber=items.biblionumber";
+ # my $sth2=$dbh->prepare($query);
+ # $sth2->execute;
+ # my $data2=$sth2->fetchrow_hashref;
+ # $sth2->finish;
+ # $data=$data2;
+ # }
+ $acctlines[$numlines] = $data;
+ $numlines++;
+ $total += $data->{'amountoutstanding'};
}
- closedir(DIR);
- return "http://cc.neu.edu.tr/stdpictures/".$cardnumber.".jpg";
+ $sth->finish;
+ return ( $numlines, \@acctlines, $total );
}
-sub change_user_pass {
- my ($uid,$member,$digest) = @_;
+=head2 GetBorNotifyAcctRecord
+
+ ($count, $acctlines, $total) = &GetBorNotifyAcctRecord($env, $params,$notifyid);
+
+Looks up accounting data for the patron with the given borrowernumber per file number.
+
+C<$env> is ignored.
+
+(FIXME - I'm not at all sure what this is about.)
+
+C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
+reference-to-array, where each element is a reference-to-hash; the
+keys are the fields of the C<accountlines> table in the Koha database.
+C<$count> is the number of elements in C<$acctlines>. C<$total> is the
+total amount outstanding for all of the account lines.
+
+=cut
+
+sub GetBorNotifyAcctRecord {
+ my ( $env, $params, $notifyid ) = @_;
my $dbh = C4::Context->dbh;
- #Make sure the userid chosen is unique and not theirs if non-empty. If it is not,
- #Then we need to tell the user and have them create a new one.
- my $sth=$dbh->prepare("select * from borrowers where userid=? and borrowernumber <> ?");
- $sth->execute($uid,$member);
- if ( ($uid ne '') && ($sth->fetchrow) ) {
+ my @acctlines;
+ my $numlines = 0;
+ my $query = qq| SELECT *
+ FROM accountlines
+ WHERE borrowernumber=?
+ AND notify_id=?
+ AND (accounttype='FU' OR accounttype='N' OR accounttype='M'OR accounttype='A'OR accounttype='F'OR accounttype='L' OR accounttype='IP' OR accounttype='CH' OR accounttype='RE' OR accounttype='RL')
+ AND amountoutstanding != '0'
+ ORDER BY notify_id,accounttype
+ |;
+ my $sth = $dbh->prepare($query);
- return 0;
- } else {
- #Everything is good so we can update the information.
- $sth=$dbh->prepare("update borrowers set userid=?, password=? where borrowernumber=?");
- $sth->execute($uid, $digest, $member);
- return 1;
+ $sth->execute( $params->{'borrowernumber'}, $notifyid );
+ my $total = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $acctlines[$numlines] = $data;
+ $numlines++;
+ $total += $data->{'amountoutstanding'};
}
-
+ $sth->finish;
+ return ( $numlines, \@acctlines, $total );
}
=head2 checkuniquemember (OUEST-PROVENCE)
@@ -1234,6 +1073,7 @@
C<&dateofbirth> is the date of birth (only if collectivity=0)
=cut
+
sub checkuniquemember {
my ( $collectivity, $surname, $firstname, $dateofbirth ) = @_;
my $dbh = C4::Context->dbh;
@@ -1269,6 +1109,7 @@
return 0;
}
}
+
=head2 getzipnamecity (OUEST-PROVENCE)
take all info from table city for the fields city and zip
@@ -1310,7 +1151,9 @@
}
=head2 getdcity (OUEST-PROVENCE)
+
recover cityid with city_name condition
+
=cut
sub getidcity {
@@ -1341,23 +1184,106 @@
return $category_type, $description;
}
+sub calcexpirydate {
+ my ( $categorycode, $dateenrolled ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "select enrolmentperiod from categories where categorycode=?");
+ $sth->execute($categorycode);
+ my ($enrolmentperiod) = $sth->fetchrow;
+ $enrolmentperiod = 12 unless ($enrolmentperiod);
+# warn "Avant format_date_in_iso :".$dateenrolled;
+# $dateenrolled=format_date_in_iso($dateenrolled);
+# warn "Apres format_date_in_iso :".$dateenrolled;
+ my @date=split /-/,format_date_in_iso($dateenrolled);
+ @date=Add_Delta_YM($date[0],$date[1],$date[2],0,$enrolmentperiod);
+ return sprintf("%04d-%02d-%02d",$date[0],$date[1],$date[2]);
+}
+
+=head2 checkuserpassword (OUEST-PROVENCE)
+
+check for the password and login are not used
+return the number of record
+0=> NOT USED 1=> USED
+
+=cut
+
+sub checkuserpassword {
+ my ( $borrowernumber, $userid, $password ) = @_;
+ $password = md5_base64($password);
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"Select count(*) from borrowers where borrowernumber !=? and userid =? and password=? "
+ );
+ $sth->execute( $borrowernumber, $userid, $password );
+ my $number_rows = $sth->fetchrow;
+ return $number_rows;
+}
+=head2 GetborCatFromCatType
+ ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
+Looks up the different types of borrowers in the database. Returns two
+elements: a reference-to-array, which lists the borrower category
+codes, and a reference-to-hash, which maps the borrower category codes
+to category descriptions.
+=cut
-# # A better approach might be to set borrowernumber autoincrement and
-#
- sub NewBorrowerNumber {
+#'
+sub GetborCatFromCatType {
+ my ( $category_type, $action ) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select max(borrowernumber) from borrowers");
- $sth->execute;
- my $data=$sth->fetchrow_hashref;
- $sth->finish;
- $data->{'max(borrowernumber)'}++;
- return($data->{'max(borrowernumber)'});
+ my $request = qq| SELECT categorycode,description
+ FROM categories
+ $action
+ ORDER BY categorycode|;
+ my $sth = $dbh->prepare($request);
+ if ($action) {
+ $sth->execute($category_type);
+ }
+ else {
+ $sth->execute();
+ }
+
+ my %labels;
+ my @codes;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @codes, $data->{'categorycode'};
+ $labels{ $data->{'categorycode'} } = $data->{'description'};
}
+ $sth->finish;
+ return ( \@codes, \%labels );
+}
+
+=head2 getborrowercategory
+
+ $description,$dateofbirthrequired,$upperagelimit,$category_type = &getborrowercategory($categorycode);
+
+Given the borrower's category code, the function returns the corresponding
+description , dateofbirthrequired , upperagelimit and category type for a comprehensive information display.
+
+=cut
+
+sub getborrowercategory {
+ my ($catcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"SELECT description,dateofbirthrequired,upperagelimit,category_type FROM categories WHERE categorycode = ?"
+ );
+ $sth->execute($catcode);
+ my ( $description, $dateofbirthrequired, $upperagelimit, $category_type ) =
+ $sth->fetchrow();
+ $sth->finish();
+ return ( $description, $dateofbirthrequired, $upperagelimit,
+ $category_type );
+} # sub getborrowercategory
=head2 ethnicitycategories
@@ -1398,9 +1324,9 @@
#'
-sub fixEthnicity($) {
-
+sub fixEthnicity {
my $ethnicity = shift;
+ return unless $ethnicity;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("Select name from ethnicity where code = ?");
$sth->execute($ethnicity);
@@ -1409,8 +1335,6 @@
return $data->{'name'};
} # sub fixEthnicity
-
-
=head2 get_age
$dateofbirth,$date = &get_age($date);
@@ -1418,31 +1342,31 @@
this function return the borrowers age with the value of dateofbirth
=cut
+
#'
sub get_age {
- my ($date, $date_ref) = @_;
+ my ( $date, $date_ref ) = @_;
- if (not defined $date_ref) {
- $date_ref = get_today();
+ if ( not defined $date_ref ) {
+ $date_ref = sprintf( '%04d-%02d-%02d', Today() );
}
- my ($year1, $month1, $day1) = split /-/, $date;
- my ($year2, $month2, $day2) = split /-/, $date_ref;
+ my ( $year1, $month1, $day1 ) = split /-/, $date;
+ my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
my $age = $year2 - $year1;
- if ($month1.$day1 > $month2.$day2) {
+ if ( $month1 . $day1 > $month2 . $day2 ) {
$age--;
}
return $age;
-}# sub get_age
-
-
+} # sub get_age
=head2 get_institutions
$insitutions = get_institutions();
Just returns a list of all the borrowers of type I, borrownumber and name
+
=cut
#'
@@ -1477,8 +1401,8 @@
my $query =
"INSERT INTO borrowers_to_borrowers (borrower1,borrower2) VALUES (?,?)";
my $sth = $dbh->prepare($query);
- foreach my $bornum (@$otherborrowers) {
- $sth->execute( $borrowernumber, $bornum );
+ foreach my $otherborrowernumber (@$otherborrowers) {
+ $sth->execute( $borrowernumber, $otherborrowernumber );
}
$sth->finish();
@@ -1496,46 +1420,377 @@
=back
=cut
+
sub GetBorrowersFromSurname {
- my ($searchstring)=@_;
+ my ($searchstring) = @_;
my $dbh = C4::Context->dbh;
- $searchstring=~ s/\'/\\\'/g;
- my @data=split(' ',$searchstring);
- my $count=@data;
+ $searchstring =~ s/\'/\\\'/g;
+ my @data = split( ' ', $searchstring );
+ my $count = @data;
my $query = qq|
SELECT surname,firstname
FROM borrowers
WHERE (surname like ?)
ORDER BY surname
|;
- my $sth=$dbh->prepare($query);
+ my $sth = $dbh->prepare($query);
$sth->execute("$data[0]%");
my @results;
- my $count = 0;
- while (my $data=$sth->fetchrow_hashref){
- push(@results,$data);
+ $count = 0;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
$count++;
}
$sth->finish;
- return ($count,\@results);
+ return ( $count, \@results );
+}
+
+=head2 citycaracteristiques (OUEST-PROVENCE)
+
+ ($id_cityarrayref, $city_hashref) = &citycaracteristic();
+
+Looks up the different city and zip in the database. Returns two
+elements: a reference-to-array, which lists the zip city
+codes, and a reference-to-hash, which maps the name of the city.
+WHERE =>OUEST PROVENCE OR EXTERIEUR
+
+=cut
+
+sub GetCities {
+
+ #my ($type_city) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|SELECT cityid,city_name
+ FROM cities
+ ORDER BY city_name|;
+ my $sth = $dbh->prepare($query);
+
+ #$sth->execute($type_city);
+ $sth->execute();
+ my %city;
+ my @id;
+
+ # insert empty value to create a empty choice in cgi popup
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ push @id, $data->{'cityid'};
+ $city{ $data->{'cityid'} } = $data->{'city_name'};
+ }
+
+#test to know if the table contain some records if no the function return nothing
+ my $id = @id;
+ $sth->finish;
+ if ( $id eq 0 ) {
+ return ();
+ }
+ else {
+ unshift( @id, "" );
+ return ( \@id, \%city );
+ }
+}
+
+=head2 GetSortDetails (OUEST-PROVENCE)
+
+ ($lib) = &GetSortDetails($category,$sortvalue);
+
+Returns the authorized value details
+C<&$lib>return value of authorized value details
+C<&$sortvalue>this is the value of authorized value
+C<&$category>this is the value of authorized value category
+
+=cut
+
+sub GetSortDetails {
+ my ( $category, $sortvalue ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|SELECT lib
+ FROM authorised_values
+ WHERE category=?
+ AND authorised_value=? |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $category, $sortvalue );
+ my $lib = $sth->fetchrow;
+ return ($lib);
+}
+
+=head2 DeleteBorrower
+
+ () = &DeleteBorrower($member);
+
+delete all data fo borrowers and add record to deletedborrowers table
+C<&$member>this is the borrowernumber
+
+=cut
+
+sub DeleteBorrower {
+ my ($member) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query;
+ $query = qq|SELECT *
+ FROM borrowers
+ WHERE borrowernumber=?|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($member);
+ my @data = $sth->fetchrow_array;
+ $sth->finish;
+ $sth =
+ $dbh->prepare( "Insert into deletedborrowers values ("
+ . ( "?," x ( scalar(@data) - 1 ) )
+ . "?)" );
+ $sth->execute(@data);
+ $sth->finish;
+ $query = qq|DELETE
+ FROM borrowers
+ WHERE borrowernumber=?|;
+ $sth = $dbh->prepare($query);
+ $sth->execute($member);
+ $sth->finish;
+ $query = qq|DELETE
+ FROM reserves
+ WHERE borrowernumber=?|;
+ $sth = $dbh->prepare($query);
+ $sth->execute($member);
+ $sth->finish;
+
+ # logging to action_log
+ &logaction(C4::Context->userenv->{'number'},"MEMBERS","DELETE",$member,"")
+ if C4::Context->preference("BorrowersLog");
+}
+
+=head2 DelBorrowerCompletly
+
+DelBorrowerCompletly($borrowernumber);
+
+This function remove directly a borrower whitout writing it on deleteborrower.
+
+=cut
+
+sub DelBorrowerCompletly {
+ my $dbh = C4::Context->dbh;
+ my $borrowernumber = shift;
+ return unless $borrowernumber; # date is mandatory.
+ my $query = "
+ DELETE *
+ FROM borrowers
+ WHERE borrowernumber = ?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber);
+ return $sth->rows;
+}
+
+=head2 member_reregistration (OUEST-PROVENCE)
+
+automatic reregistration in borrowers table
+with dateexpiry .
+
+=cut
+
+sub GetMembeReregistration {
+ my ( $categorycode, $borrowerid ) = @_;
+ my $dbh = C4::Context->dbh;
+ my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
+ localtime(time);
+ $mon++;
+ $year = $year + 1900;
+ if ( $mon < '10' ) {
+ $mon = "0" . $mon;
+ }
+ if ( $mday < '10' ) {
+ $mday = "0" . $mday;
+ }
+ my $today = sprintf("%04d-%02d-%02d",$year,$mon,$mday);
+ my $dateexpiry = calcexpirydate( $categorycode, $today );
+ my $query = qq| UPDATE borrowers
+ SET dateexpiry='$dateexpiry'
+ WHERE borrowernumber='$borrowerid'|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ $sth->finish;
+ return $dateexpiry;
+}
+
+=head2 GetRoadTypes (OUEST-PROVENCE)
+
+ ($idroadtypearrayref, $roadttype_hashref) = &GetRoadTypes();
+
+Looks up the different road type . Returns two
+elements: a reference-to-array, which lists the id_roadtype
+codes, and a reference-to-hash, which maps the road type of the road .
+
+
+=cut
+
+sub GetRoadTypes {
+ my $dbh = C4::Context->dbh;
+ my $query = qq|SELECT roadtypeid,road_type
+ FROM roadtype
+ ORDER BY road_type|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my %roadtype;
+ my @id;
+
+ # insert empty value to create a empty choice in cgi popup
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ push @id, $data->{'roadtypeid'};
+ $roadtype{ $data->{'roadtypeid'} } = $data->{'road_type'};
+ }
+
+#test to know if the table contain some records if no the function return nothing
+ my $id = @id;
+ $sth->finish;
+ if ( $id eq 0 ) {
+ return ();
+ }
+ else {
+ unshift( @id, "" );
+ return ( \@id, \%roadtype );
+ }
+}
+
+
+
+=head2 GetBorrowersTitles (OUEST-PROVENCE)
+
+ ($borrowertitle)= &GetBorrowersTitles();
+
+Looks up the different title . Returns array with all borrowers title
+
+=cut
+
+sub GetBorrowersTitles {
+ my @borrowerTitle = split /,|\|/,C4::Context->preference('BorrowersTitles');
+ unshift( @borrowerTitle, "" );
+ return ( \@borrowerTitle);
+ }
+
+
+
+=head2 GetRoadTypeDetails (OUEST-PROVENCE)
+
+ ($roadtype) = &GetRoadTypeDetails($roadtypeid);
+
+Returns the description of roadtype
+C<&$roadtype>return description of road type
+C<&$roadtypeid>this is the value of roadtype s
+
+=cut
+
+sub GetRoadTypeDetails {
+ my ($roadtypeid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|SELECT road_type
+ FROM roadtype
+ WHERE roadtypeid=?|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($roadtypeid);
+ my $roadtype = $sth->fetchrow;
+ return ($roadtype);
+}
+
+=head2 GetBorrowersWhoHaveNotBorrowedSince
+
+&GetBorrowersWhoHaveNotBorrowedSince($date)
+
+this function get all borrowers who haven't borrowed since the date given on input arg.
+
+=cut
+
+sub GetBorrowersWhoHaveNotBorrowedSince {
+ my $date = shift;
+ return unless $date; # date is mandatory.
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT borrowers.borrowernumber,max(timestamp)
+ FROM borrowers
+ LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
+ WHERE issues.borrowernumber IS NOT NULL
+ GROUP BY borrowers.borrowernumber
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my @results;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
+ }
+ return \@results;
+}
+
+=head2 GetBorrowersWhoHaveNeverBorrowed
+
+$results = &GetBorrowersWhoHaveNeverBorrowed
+
+this function get all borrowers who have never borrowed.
+
+I<$result> is a ref to an array which all elements are a hasref.
+
+=cut
+
+sub GetBorrowersWhoHaveNeverBorrowed {
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT borrowers.borrowernumber,max(timestamp)
+ FROM borrowers
+ LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
+ WHERE issues.borrowernumber IS NULL
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
+ }
+ return \@results;
}
-=head2 expand_sex_into_predicate
+=head2 GetBorrowersWithIssuesHistoryOlderThan
- $data{&expand_sex_into_predicate($data{sex})} = 1;
+$results = &GetBorrowersWithIssuesHistoryOlderThan($date)
-Converts a single 'M' or 'F' into 'sex_M_p' or 'sex_F_p'
-respectively.
+this function get all borrowers who has an issue history older than I<$date> given on input arg.
-In some languages, 'M' and 'F' are not appropriate. However,
-with HTML::Template, there is no way to localize 'M' or 'F'
-unless these are converted into variables that TMPL_IF can
-understand. This function provides this conversion.
+I<$result> is a ref to an array which all elements are a hashref.
+This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
=cut
-sub expand_sex_into_predicate ($) {
- my($sex) = @_;
- return "sex_${sex}_p";
-} # expand_sex_into_predicate
+sub GetBorrowersWithIssuesHistoryOlderThan {
+ my $dbh = C4::Context->dbh;
+ my $date = shift;
+ return unless $date; # date is mandatory.
+ my $query = "
+ SELECT count(borrowernumber) as n,borrowernumber
+ FROM issues
+ WHERE returndate < ?
+ AND borrowernumber IS NOT NULL
+ GROUP BY borrowernumber
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($date);
+ my @results;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
+ }
+ return \@results;
+}
+
+END { } # module clean-up code here (global destructor)
+
1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Team
+
+=cut
Index: NewsChannels.pm
===================================================================
RCS file: /sources/koha/koha/C4/NewsChannels.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- NewsChannels.pm 20 Oct 2006 01:20:56 -0000 1.3
+++ NewsChannels.pm 9 Mar 2007 14:31:47 -0000 1.4
@@ -25,7 +25,9 @@
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.4 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -44,6 +46,7 @@
@ISA = qw(Exporter);
@EXPORT = qw(
+ &GetNewsToDisplay
&news_channels &get_new_channel &del_channels &add_channel &update_channel
&news_channels_categories &get_new_channel_category &del_channels_categories
&add_channel_category &update_channel_category &news_channels_by_category
@@ -236,21 +239,28 @@
return 1;
}
-
sub add_opac_new {
- my ($title, $new, $lang) = @_;
+ my ($title, $new, $lang, $expirationdate, $number) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("INSERT INTO opac_news (title, new, lang) VALUES (?,?,?)");
- $sth->execute($title, $new, $lang);
+ my $sth = $dbh->prepare("INSERT INTO opac_news (title, new, lang, expirationdate, number) VALUES (?,?,?,?,?)");
+ $sth->execute($title, $new, $lang, $expirationdate, $number);
$sth->finish;
return 1;
}
sub upd_opac_new {
- my ($idnew, $title, $new, $lang) = @_;
+ my ($idnew, $title, $new, $lang, $expirationdate, $number) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("UPDATE opac_news SET title = ?, new = ?, lang = ? WHERE idnew = ?");
- $sth->execute($title, $new, $lang, $idnew);
+ my $sth = $dbh->prepare("
+ UPDATE opac_news SET
+ title = ?,
+ new = ?,
+ lang = ?,
+ expirationdate = ?,
+ number = ?
+ WHERE idnew = ?
+ ");
+ $sth->execute($title, $new, $lang, $expirationdate,$number,$idnew);
$sth->finish;
return 1;
}
@@ -282,7 +292,7 @@
sub get_opac_news {
my ($limit, $lang) = @_;
my $dbh = C4::Context->dbh;
- my $query = "SELECT *, DATE_FORMAT(timestamp,'%Y-%m-%d') AS newdate FROM opac_news";
+ my $query = "SELECT *, DATE_FORMAT(timestamp, '%d/%m/%Y') AS newdate FROM opac_news";
if ($lang) {
$query.= " WHERE lang = '" .$lang ."' ";
}
@@ -304,6 +314,37 @@
return ($count, \@opac_news);
}
+=head2 GetNewsToDisplay
+
+ $news = &GetNewsToDisplay($lang);
+ C<$news> is a ref to an array which containts
+ all news with expirationdate > today or expirationdate is null.
+
+=cut
+
+sub GetNewsToDisplay {
+ my $lang = shift;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT *,DATE_FORMAT(timestamp, '%d/%m/%Y') AS newdate
+ FROM opac_news
+ WHERE (
+ expirationdate > CURRENT_DATE()
+ OR expirationdate IS NULL
+ OR expirationdate = '00-00-0000'
+ )
+ AND lang = ?
+ ORDER BY number
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($lang);
+ my @results;
+ while ( my $row = $sth->fetchrow_hashref ){
+ push @results, $row;
+ }
+ return \@results;
+}
+
### get electronic databases
sub add_opac_electronic {
@@ -352,7 +393,7 @@
sub get_opac_electronics {
my ($section, $lang) = @_;
my $dbh = C4::Context->dbh;
- my $query = "SELECT *, DATE_FORMAT(timestamp, '%Y-%m-%d') AS newdate FROM opac_electronic";
+ my $query = "SELECT *, DATE_FORMAT(timestamp, '%d/%m/%Y') AS newdate FROM opac_electronic";
if ($lang) {
$query.= " WHERE lang = '" .$lang ."' ";
}
@@ -366,7 +407,6 @@
my @opac_electronic;
my $count = 0;
while (my $row = $sth->fetchrow_hashref) {
- $row->{'newdate'}=format_date($row->{'newdate'});
push @opac_electronic, $row;
Index: Output.pm
===================================================================
RCS file: /sources/koha/koha/C4/Output.pm,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -b -r1.59 -r1.60
--- Output.pm 6 Sep 2006 16:21:03 -0000 1.59
+++ Output.pm 9 Mar 2007 14:31:47 -0000 1.60
@@ -1,11 +1,9 @@
package C4::Output;
-# $Id: Output.pm,v 1.59 2006/09/06 16:21:03 tgarip1957 Exp $
#package to deal with marking up output
#You will need to edit parts of this pm
#set the value of path to be where your html lives
-
# Copyright 2000-2002 Katipo Communications
#
# This file is part of Koha.
@@ -23,6 +21,10 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+# $Id: Output.pm,v 1.60 2007/03/09 14:31:47 tipaul Exp $
+
+# NOTE: I'm pretty sure this module is deprecated in favor of
+# templates.
use strict;
require Exporter;
@@ -33,7 +35,7 @@
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.60 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -48,47 +50,49 @@
@ISA = qw(Exporter);
@EXPORT = qw(
&themelanguage &gettemplate setlanguagecookie pagination_bar
- );
+);
#FIXME: this is a quick fix to stop rc1 installing broken
#Still trying to figure out the correct fix.
-my $path = C4::Context->config('intrahtdocs')."/default/en/includes/";
+my $path = C4::Context->config('intrahtdocs') . "/default/en/includes/";
#---------------------------------------------------------------------------------------------------------
# FIXME - POD
sub gettemplate {
- my ($tmplbase, $opac, $query) = @_;
-if (!$query){
+ my ( $tmplbase, $opac, $query ) = @_;
+ if ( !$query ) {
warn "no query in gettemplate";
}
my $htdocs;
- if ($opac ne "intranet") {
+ if ( $opac ne "intranet" ) {
$htdocs = C4::Context->config('opachtdocs');
- } else {
+ }
+ else {
$htdocs = C4::Context->config('intrahtdocs');
}
my $path = C4::Context->preference('intranet_includes') || 'includes';
-# warn "PATH : $path";
-my $filter=sub {
-#my $win=shift;
-$_=~s /\xef\xbb\xbf//g;
-};
- my ($theme, $lang) = themelanguage($htdocs, $tmplbase, $opac, $query);
- my $opacstylesheet = C4::Context->preference('opacstylesheet');
-my $template = HTML::Template::Pro->new(filename => "$htdocs/$theme/$lang/$tmplbase", case_sensitive=>1,
- die_on_bad_params => 0,
+ # warn "PATH : $path";
+ my ( $theme, $lang ) = themelanguage( $htdocs, $tmplbase, $opac, $query );
+ my $opacstylesheet = C4::Context->preference('opacstylesheet');
+ my $template = HTML::Template::Pro->new(
+ filename => "$htdocs/$theme/$lang/$tmplbase",
+ die_on_bad_params => 1,
global_vars => 1,
- path => ["$htdocs/$theme/$lang/$path"]);
+ case_sensitive => 1,
+ path => ["$htdocs/$theme/$lang/$path"]
+ );
- $template->param(themelang => ($opac ne 'intranet'? '/opac-tmpl': '/intranet-tmpl') . "/$theme/$lang",
- interface => ($opac ne 'intranet'? '/opac-tmpl': '/intranet-tmpl'),
+ $template->param(
+ themelang => ( $opac ne 'intranet' ? '/opac-tmpl' : '/intranet-tmpl' )
+ . "/$theme/$lang",
+ interface => ( $opac ne 'intranet' ? '/opac-tmpl' : '/intranet-tmpl' ),
theme => $theme,
opacstylesheet => $opacstylesheet,
opaccolorstylesheet => C4::Context->preference('opaccolorstylesheet'),
opacsmallimage => C4::Context->preference('opacsmallimage'),
- lang => $lang);
-
+ lang => $lang
+ );
return $template;
}
@@ -96,49 +100,45 @@
#---------------------------------------------------------------------------------------------------------
# FIXME - POD
sub themelanguage {
- my ($htdocs, $tmpl, $section, $query) = @_;
-# if (!$query) {
-# warn "no query";
-# }
+ my ( $htdocs, $tmpl, $section, $query ) = @_;
+
+ # if (!$query) {
+ # warn "no query";
+ # }
my $dbh = C4::Context->dbh;
my @languages;
my @themes;
-my ($theme, $lang);
- if ($section eq "intranet"){
- $lang=$query->cookie('KohaOpacLanguage');
-
- if ($lang){
-
- push @languages,$lang;
- @themes = split " ", C4::Context->preference("template");
- }
- else {
+ if ( $section eq "intranet" ) {
@languages = split " ", C4::Context->preference("opaclanguages");
@themes = split " ", C4::Context->preference("template");
}
- }else{
- $lang=$query->cookie('KohaOpacLanguage');
+ else {
- if ($lang){
+ # we are in the opac here, what im trying to do is let the individual user
+ # set the theme they want to use.
+ # and perhaps the them as well.
+ my $lang = $query->cookie('KohaOpacLanguage');
+ if ($lang) {
- push @languages,$lang;
+ push @languages, $lang;
@themes = split " ", C4::Context->preference("opacthemes");
}
else {
@languages = split " ", C4::Context->preference("opaclanguages");
@themes = split " ", C4::Context->preference("opacthemes");
}
-}
+ }
+ my ( $theme, $lang );
-# searches through the themes and languages. First template it find it returns.
-# Priority is for getting the theme right.
+ # searches through the themes and languages. First template it find it returns.
+ # Priority is for getting the theme right.
THEME:
foreach my $th (@themes) {
foreach my $la (@languages) {
- for (my $pass = 1; $pass <= 2; $pass += 1) {
+ for ( my $pass = 1 ; $pass <= 2 ; $pass += 1 ) {
$la =~ s/([-_])/ $1 eq '-'? '_': '-' /eg if $pass == 2;
- if (-e "$htdocs/$th/$la/$tmpl") {
+ if ( -e "$htdocs/$th/$la/$tmpl" ) {
$theme = $th;
$lang = $la;
last THEME;
@@ -147,21 +147,25 @@
}
}
}
- if ($theme and $lang) {
- return ($theme, $lang);
- } else {
- return ('default', 'en');
+ if ( $theme and $lang ) {
+ return ( $theme, $lang );
+ }
+ else {
+ return ( 'prog', 'en' );
}
}
-
sub setlanguagecookie {
- my ($query,$language,$uri)=@_;
- my $cookie=$query->cookie(-name => 'KohaOpacLanguage',
+ my ( $query, $language, $uri ) = @_;
+ my $cookie = $query->cookie(
+ -name => 'KohaOpacLanguage',
-value => $language,
- -expires => '');
- print $query->redirect(-uri=>$uri,
- -cookie=>$cookie);
+ -expires => ''
+ );
+ print $query->redirect(
+ -uri => $uri,
+ -cookie => $cookie
+ );
}
=item pagination_bar
@@ -184,125 +188,125 @@
=cut
sub pagination_bar {
- my ($base_url, $nb_pages, $current_page, $startfrom_name) = @_;
+ my ( $base_url, $nb_pages, $current_page, $startfrom_name ) = @_;
# how many pages to show before and after the current page?
my $pages_around = 2;
my $url =
- $base_url
- .($base_url =~ m/&/ ? '&' : '?')
- .$startfrom_name.'='
- ;
+ $base_url . ( $base_url =~ m/&/ ? '&' : '?' ) . $startfrom_name . '=';
my $pagination_bar = '';
# current page detection
- if (not defined $current_page) {
+ if ( not defined $current_page ) {
$current_page = 1;
}
# navigation bar useful only if more than one page to display !
- if ($nb_pages > 1) {
+ if ( $nb_pages > 1 ) {
+
# link to first page?
- if ($current_page > 1) {
- $pagination_bar.=
- "\n".' '
- .'<a href="'.$url.'1" rel="start">'
- .'<<'
- .'</a>'
- ;
+ if ( $current_page > 1 ) {
+ $pagination_bar .=
+ "\n" . ' '
+ . '<a href="'
+ . $url
+ . '1" rel="start">'
+ . '<<' . '</a>';
}
else {
- $pagination_bar.=
- "\n".' <span class="inactive"><<</span>';
+ $pagination_bar .=
+ "\n" . ' <span class="inactive"><<</span>';
}
# link on previous page ?
- if ($current_page > 1) {
+ if ( $current_page > 1 ) {
my $previous = $current_page - 1;
- $pagination_bar.=
- "\n".' '
- .'<a href="'
- .$url.$previous
- .'" rel="prev">'
- .'<'
- .'</a>'
- ;
+ $pagination_bar .=
+ "\n" . ' '
+ . '<a href="'
+ . $url
+ . $previous
+ . '" rel="prev">' . '<' . '</a>';
}
else {
- $pagination_bar.=
- "\n".' <span class="inactive"><</span>';
+ $pagination_bar .=
+ "\n" . ' <span class="inactive"><</span>';
}
my $min_to_display = $current_page - $pages_around;
my $max_to_display = $current_page + $pages_around;
my $last_displayed_page = undef;
- for my $page_number (1..$nb_pages) {
- if ($page_number == 1
+ for my $page_number ( 1 .. $nb_pages ) {
+ if (
+ $page_number == 1
or $page_number == $nb_pages
- or ($page_number >= $min_to_display and $page_number <= $max_to_display)
- ) {
- if (defined $last_displayed_page
- and $last_displayed_page != $page_number - 1
- ) {
- $pagination_bar.=
- "\n".' <span class="inactive">...</span>'
- ;
- }
-
- if ($page_number == $current_page) {
- $pagination_bar.=
- "\n".' '
- .'<span class="currentPage">'.$page_number.'</span>'
- ;
+ or ( $page_number >= $min_to_display
+ and $page_number <= $max_to_display )
+ )
+ {
+ if ( defined $last_displayed_page
+ and $last_displayed_page != $page_number - 1 )
+ {
+ $pagination_bar .=
+ "\n" . ' <span class="inactive">...</span>';
+ }
+
+ if ( $page_number == $current_page ) {
+ $pagination_bar .=
+ "\n" . ' '
+ . '<span class="currentPage">'
+ . $page_number
+ . '</span>';
}
else {
- $pagination_bar.=
- "\n".' '
- .'<a href="'.$url.$page_number.'">'.$page_number.'</a>'
- ;
+ $pagination_bar .=
+ "\n" . ' '
+ . '<a href="'
+ . $url
+ . $page_number . '">'
+ . $page_number . '</a>';
}
$last_displayed_page = $page_number;
}
}
# link on next page?
- if ($current_page < $nb_pages) {
+ if ( $current_page < $nb_pages ) {
my $next = $current_page + 1;
- $pagination_bar.=
- "\n".' <a href="'.$url.$next.'" rel="next">'
- .'>'
- .'</a>'
- ;
+ $pagination_bar .= "\n"
+ . ' <a href="'
+ . $url
+ . $next
+ . '" rel="next">' . '>' . '</a>';
}
else {
- $pagination_bar.=
- "\n".' <span class="inactive">></span>'
- ;
+ $pagination_bar .=
+ "\n" . ' <span class="inactive">></span>';
}
# link to last page?
- if ($current_page != $nb_pages) {
- $pagination_bar.=
- "\n".' <a href="'.$url.$nb_pages.'" rel="last">'
- .'>>'
- .'</a>'
- ;
+ if ( $current_page != $nb_pages ) {
+ $pagination_bar .= "\n"
+ . ' <a href="'
+ . $url
+ . $nb_pages
+ . '" rel="last">'
+ . '>>' . '</a>';
}
else {
- $pagination_bar.=
- "\n".' <span class="inactive">>></span>';
+ $pagination_bar .=
+ "\n" . ' <span class="inactive">>></span>';
}
}
return $pagination_bar;
}
-
END { } # module clean-up code here (global destructor)
1;
Index: Print.pm
===================================================================
RCS file: /sources/koha/koha/C4/Print.pm,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -b -r1.18 -r1.19
--- Print.pm 20 Oct 2006 01:20:56 -0000 1.18
+++ Print.pm 9 Mar 2007 14:31:47 -0000 1.19
@@ -1,5 +1,4 @@
-package C4::Print; #assumes C4/Print.pm
-
+package C4::Print;
# Copyright 2000-2002 Katipo Communications
#
@@ -18,17 +17,21 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+# $Id: Print.pm,v 1.19 2007/03/09 14:31:47 tipaul Exp $
+
use strict;
require Exporter;
-
use C4::Context;
use C4::Circulation::Circ2;
-use C4::Members;
+
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.19 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -70,13 +73,16 @@
from C<¤tissues>.
=cut
+
#'
# FIXME - It'd be nifty if this could generate pretty PostScript.
sub remoteprint {
- my ($env,$items,$borrower)=@_;
+ my ( $env, $items, $borrower ) = @_;
- (return) unless (C4::Context->boolean_preference('printcirculationslips'));
+ (return)
+ unless ( C4::Context->boolean_preference('printcirculationslips') );
my $queue = $env->{'queue'};
+
# FIXME - If 'queue' is undefined or empty, then presumably it should
# mean "use the default queue", whatever the default is. Presumably
# the default depends on the physical location of the machine.
@@ -84,59 +90,72 @@
# set the queue to "file" (or " file", if real queues aren't allowed
# to have spaces in them). Or perhaps if $queue eq "" and
# $env->{file} ne "", then that should mean "print to $env->{file}".
- if ($queue eq "" || $queue eq 'nulllp') {
- open (PRINTER,">/tmp/kohaiss");
- } else {
+ if ( $queue eq "" || $queue eq 'nulllp' ) {
+ open( PRINTER, ">/tmp/kohaiss" );
+ }
+ else {
+
# FIXME - This assumes that 'lpr' exists, and works as expected.
# This is a reasonable assumption, but only because every other
# printing package has a wrapper script called 'lpr'. It'd still
# be better to be able to customize this.
- open(PRINTER, "| lpr -P $queue > /dev/null") or die "Couldn't write to queue:$queue!\n";
+ open( PRINTER, "| lpr -P $queue > /dev/null" )
+ or die "Couldn't write to queue:$queue!\n";
}
-# print $queue;
+
+ # print $queue;
#open (FILE,">/tmp/$file");
- my $i=0;
+ my $i = 0;
my $brdata = $env->{'brdata'}; # FIXME - Not used
# FIXME - This is HLT-specific. Put this stuff in a customizable
# site-specific file somewhere.
print PRINTER "Horowhenua Library Trust\r\n";
-# print PRINTER "$brdata->{'branchname'}\r\n";
+
+ # print PRINTER "$brdata->{'branchname'}\r\n";
print PRINTER "Phone: 368-1953\r\n";
print PRINTER "Fax: 367-9218\r\n";
print PRINTER "Email: renewals\@library.org.nz\r\n\r\n\r\n";
print PRINTER "$borrower->{'cardnumber'}\r\n";
- print PRINTER "$borrower->{'title'} $borrower->{'initials'} $borrower->{'surname'}\r\n";
+ print PRINTER
+ "$borrower->{'title'} $borrower->{'initials'} $borrower->{'surname'}\r\n";
+
# FIXME - Use for ($i = 0; $items->[$i]; $i++)
# Or better yet, foreach $item (@{$items})
- while ($items->[$i]){
-# print $i;
+ while ( $items->[$i] ) {
+
+ # print $i;
my $itemdata = $items->[$i];
+
# FIXME - This is just begging for a Perl format.
print PRINTER "$i $itemdata->{'title'}\r\n";
print PRINTER "$itemdata->{'barcode'}";
- print PRINTER " "x15;
+ print PRINTER " " x 15;
print PRINTER "$itemdata->{'date_due'}\r\n";
$i++;
}
print PRINTER "\r\n\r\n\r\n\r\n\r\n\r\n\r\n";
- if ($env->{'printtype'} eq "docket"){
+ if ( $env->{'printtype'} eq "docket" ) {
+
#print chr(27).chr(105);
}
close PRINTER;
+
#system("lpr /tmp/$file");
}
sub printreserve {
- my($env, $branchname, $bordata, $itemdata)=@_;
- my $file=time;
+ my ( $env, $branchname, $bordata, $itemdata ) = @_;
+ my $file = time;
my $printer = $env->{'printer'};
- (return) unless (C4::Context->boolean_preference('printreserveslips'));
- if ($printer eq "" || $printer eq 'nulllp') {
- open (PRINTER,">>/tmp/kohares");
- } else {
- open (PRINTER, "| lpr -P $printer >/dev/null") or die "Couldn't write to queue:$!\n";
+ (return) unless ( C4::Context->boolean_preference('printreserveslips') );
+ if ( $printer eq "" || $printer eq 'nulllp' ) {
+ open( PRINTER, ">>/tmp/kohares" );
+ }
+ else {
+ open( PRINTER, "| lpr -P $printer >/dev/null" )
+ or die "Couldn't write to queue:$!\n";
}
- my @da = localtime(time());
+ my @da = localtime( time() );
my $todaysdate = "$da[2]:$da[1] $da[3]/$da[4]/$da[5]";
#(1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
@@ -174,37 +193,41 @@
print a slip for the given $borrowernumber
=cut
+
#'
sub printslip {
- my ($env,$borrowernumber)=@_;
- my ($borrower, $flags) = getpatroninformation($env,$borrowernumber,0);
- $env->{'todaysissues'}=1;
- my ($borrowerissues) = currentissues($env, $borrower);
- $env->{'nottodaysissues'}=1;
- $env->{'todaysissues'}=0;
- my ($borroweriss2)=currentissues($env, $borrower);
- $env->{'nottodaysissues'}=0;
- my $i=0;
+ my ( $env, $borrowernumber ) = @_;
+ my ( $borrower, $flags ) = getpatroninformation( $env, $borrowernumber, 0 );
+ $env->{'todaysissues'} = 1;
+ my ($borrowerissues) = currentissues( $env, $borrower );
+ $env->{'nottodaysissues'} = 1;
+ $env->{'todaysissues'} = 0;
+ my ($borroweriss2) = currentissues( $env, $borrower );
+ $env->{'nottodaysissues'} = 0;
+ my $i = 0;
my @issues;
- foreach (sort {$a <=> $b} keys %$borrowerissues) {
- $issues[$i]=$borrowerissues->{$_};
- my $dd=$issues[$i]->{'date_due'};
+
+ foreach ( sort { $a <=> $b } keys %$borrowerissues ) {
+ $issues[$i] = $borrowerissues->{$_};
+ my $dd = $issues[$i]->{'date_due'};
+
#convert to nz style dates
#this should be set with some kinda config variable
- my @tempdate=split(/-/,$dd);
- $issues[$i]->{'date_due'}="$tempdate[2]/$tempdate[1]/$tempdate[0]";
+ my @tempdate = split( /-/, $dd );
+ $issues[$i]->{'date_due'} = "$tempdate[2]/$tempdate[1]/$tempdate[0]";
$i++;
}
- foreach (sort {$a <=> $b} keys %$borroweriss2) {
- $issues[$i]=$borroweriss2->{$_};
- my $dd=$issues[$i]->{'date_due'};
+ foreach ( sort { $a <=> $b } keys %$borroweriss2 ) {
+ $issues[$i] = $borroweriss2->{$_};
+ my $dd = $issues[$i]->{'date_due'};
+
#convert to nz style dates
#this should be set with some kinda config variable
- my @tempdate=split(/-/,$dd);
- $issues[$i]->{'date_due'}="$tempdate[2]/$tempdate[1]/$tempdate[0]";
+ my @tempdate = split( /-/, $dd );
+ $issues[$i]->{'date_due'} = "$tempdate[2]/$tempdate[1]/$tempdate[0]";
$i++;
}
- remoteprint($env,\@issues,$borrower);
+ remoteprint( $env, \@issues, $borrower );
}
END { } # module clean-up code here (global destructor)
Index: Reserves2.pm
===================================================================
RCS file: /sources/koha/koha/C4/Reserves2.pm,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -b -r1.49 -r1.50
--- Reserves2.pm 6 Sep 2006 16:21:03 -0000 1.49
+++ Reserves2.pm 9 Mar 2007 14:31:47 -0000 1.50
@@ -3,11 +3,9 @@
package C4::Reserves2;
-# $Id: Reserves2.pm,v 1.49 2006/09/06 16:21:03 tgarip1957 Exp $
-
# Copyright 2000-2002 Katipo Communications
#
-# This file is hard coded with koha-reserves table to be used only by the OPAC -TG.
+# 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
@@ -22,24 +20,24 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+# $Id: Reserves2.pm,v 1.50 2007/03/09 14:31:47 tipaul Exp $
+
use strict;
require Exporter;
-
use C4::Context;
-use C4::Search;
use C4::Biblio;
- # FIXME - C4::Reserves2 uses C4::Search, which uses C4::Reserves2.
- # So Perl complains that all of the functions here get redefined.
-#use C4::Accounts;
+use C4::Search;
+use C4::Circulation::Circ2;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+my $library_name = C4::Context->preference("LibraryName");
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.50 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
-C4::Reserves2 - FIXME
+C4::Reserves2 - Koha functions for dealing with reservation.
=head1 SYNOPSIS
@@ -47,7 +45,7 @@
=head1 DESCRIPTION
-FIXME
+this modules provides somes functions to deal with reservations.
=head1 FUNCTIONS
@@ -56,29 +54,247 @@
=cut
@ISA = qw(Exporter);
+
# FIXME Take out CalcReserveFee after it can be removed from opac-reserves.pl
- at EXPORT = qw(&FindReserves
- &FindAllReserves
+ at EXPORT = qw(
+ &FindReserves
&CheckReserves
- &CheckWaiting
+ &GetWaitingReserves
&CancelReserve
&CalcReserveFee
&FillReserve
&ReserveWaiting
&CreateReserve
- &UpdateReserves
&UpdateReserve
- &getreservetitle
- &Findgroupreserve
- &findActiveReserve
+ &GetReserveTitle
+ &GetReservations
+ &SetWaitingStatus
+ &GlobalCancel
+ &MinusPriority
+ &OtherReserves
+ &GetFirstReserveDateFromItem
+ &CountReservesFromBorrower
+ &FixPriority
+ &FindReservesInQueue
+);
+# make all your functions, whether exported or not;
+
+=item GlobalCancel
+
+($messages,$nextreservinfo) = &GlobalCancel($itemnumber,$borrowernumber);
+
+ New op dev for the circulation based on item, global is a function to cancel reserv,check other reserves, and transfer document if it's necessary
+
+=cut
+
+#'
+sub GlobalCancel {
+ my $messages;
+ my $nextreservinfo;
+ my ( $itemnumber, $borrowernumber ) = @_;
+
+ #step 1 : cancel the reservation
+ my $CancelReserve = CancelReserve( undef, $itemnumber, $borrowernumber );
+
+ #step 2 launch the subroutine of the others reserves
+ ( $messages, $nextreservinfo ) = OtherReserves($itemnumber);
+
+ return ( $messages, $nextreservinfo );
+}
+
+=item OtherReserves
+
+($messages,$nextreservinfo)=$OtherReserves(itemnumber);
+
+Check queued list of this document and check if this document must be transfered
+
+=cut
+
+#'
+sub OtherReserves {
+ my ($itemnumber) = @_;
+ my $messages;
+ my $nextreservinfo;
+ my ( $restype, $checkreserves ) = CheckReserves($itemnumber);
+ if ($checkreserves) {
+ my $iteminfo = C4::Circulation::Circ2::getiteminformation($itemnumber,undef);
+ if ( $iteminfo->{'holdingbranch'} ne $checkreserves->{'branchcode'} ) {
+ $messages->{'transfert'} = $checkreserves->{'branchcode'};
+ #minus priorities of others reservs
+ MinusPriority(
+ $itemnumber,
+ $checkreserves->{'borrowernumber'},
+ $iteminfo->{'biblionumber'}
);
-# make all your functions, whether exported or not;
+ #launch the subroutine dotransfer
+ C4::Circulation::Circ2::dotransfer(
+ $itemnumber,
+ $iteminfo->{'holdingbranch'},
+ $checkreserves->{'branchcode'}
+ ),
+ ;
+ }
+
+ #step 2b : case of a reservation on the same branch, set the waiting status
+ else {
+ $messages->{'waiting'} = 1;
+ MinusPriority(
+ $itemnumber,
+ $checkreserves->{'borrowernumber'},
+ $iteminfo->{'biblionumber'}
+ );
+ SetWaitingStatus($itemnumber);
+ }
+
+ $nextreservinfo = $checkreserves->{'borrowernumber'};
+ }
+
+ return ( $messages, $nextreservinfo );
+}
+
+=item MinusPriority
+
+&MinusPriority($itemnumber,$borrowernumber,$biblionumber)
+
+Reduce the values of queuded list
+
+=cut
+
+#'
+sub MinusPriority {
+ my ( $itemnumber, $borrowernumber, $biblionumber ) = @_;
+
+ #first step update the value of the first person on reserv
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ UPDATE reserves
+ SET priority = 0 , itemnumber = ?
+ WHERE cancellationdate IS NULL
+ AND borrowernumber=?
+ AND biblionumber=?
+ /;
+ my $sth_upd = $dbh->prepare($query);
+ $sth_upd->execute( $itemnumber, $borrowernumber, $biblionumber );
+ $sth_upd->finish;
+ # second step update all others reservs
+ $query = qq/
+ SELECT priority,borrowernumber,biblionumber,reservedate
+ FROM reserves
+ WHERE priority !='0'
+ AND biblionumber = ?
+ AND cancellationdate IS NULL
+ /;
+ my $sth_oth = $dbh->prepare($query);
+ $sth_oth->execute($biblionumber);
+ while ( my ( $priority, $borrowernumber, $biblionumber, $reservedate ) =
+ $sth_oth->fetchrow_array )
+ {
+ $priority--;
+ $query = qq/
+ UPDATE reserves
+ SET priority = ?
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?
+ /;
+ my $sth_upd_oth = $dbh->prepare($query);
+ $sth_upd_oth->execute( $priority, $biblionumber, $borrowernumber,
+ $reservedate );
+ $sth_upd_oth->finish;
+ }
+ $sth_oth->finish;
+}
+
+=item SetWaitingStatus
+
+&SetWaitingStatus($itemnumber);
+
+we check if we have a reserves with itemnumber (New op system of reserves), if we found one, we update the status of the reservation when we have : 'priority' = 0, and we have an itemnumber
+
+=cut
+
+sub SetWaitingStatus {
+
+ #first : check if we have a reservation for this item .
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ SELECT priority,borrowernumber
+ FROM reserves
+ WHERE itemnumber=?
+ AND cancellationdate IS NULL
+ AND found IS NULL AND priority='0'
+ /;
+ my $sth_find = $dbh->prepare($query);
+ $sth_find->execute($itemnumber);
+ my ( $priority, $borrowernumber ) = $sth_find->fetchrow_array;
+ $sth_find->finish;
+ return unless $borrowernumber;
+
+# step 2 : if we have a borrowernumber, we update the value found to 'W' to notify the borrower
+ $query = qq/
+ UPDATE reserves
+ SET found='W',waitingdate = now()
+ WHERE borrowernumber=?
+ AND itemnumber=?
+ AND found IS NULL
+ /;
+ my $sth_set = $dbh->prepare($query);
+ $sth_set->execute( $borrowernumber, $itemnumber );
+ $sth_set->finish;
+}
+
+=item GetReservations
+
+ at borrowerreserv=&GetReservations($itemnumber,$borrowernumber);
+
+this function get the list of reservation for an C<$itemnumber> or C<$borrowernumber>
+given on input arg. You should give $itemnumber OR $borrowernumber but not both.
+
+=cut
+
+sub GetReservations {
+ my ( $itemnumber, $borrowernumber ) = @_;
+ if ($itemnumber) {
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ SELECT reservedate,borrowernumber
+ FROM reserves
+ WHERE itemnumber=?
+ AND cancellationdate IS NULL
+ AND (found <> 'F' OR found IS NULL)
+ /;
+ my $sth_res = $dbh->prepare($query);
+ $sth_res->execute($itemnumber);
+ my ( $reservedate, $borrowernumber ) = $sth_res->fetchrow_array;
+ return ( $reservedate, $borrowernumber );
+ }
+ if ($borrowernumber) {
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ SELECT *
+ FROM reserves
+ WHERE borrowernumber=?
+ AND cancellationdate IS NULL
+ AND (found != 'F' or found is null)
+ ORDER BY reservedate
+ /;
+
+ my $sth_find = $dbh->prepare($query);
+ $sth_find->execute($borrowernumber);
+ my @borrowerreserv;
+ while ( my $data = $sth_find->fetchrow_hashref ) {
+ push @borrowerreserv, $data;
+ }
+ return @borrowerreserv;
+ }
+}
=item FindReserves
- ($count, $results) = &FindReserves($biblionumber, $borrowernumber);
+ $results = &FindReserves($biblionumber, $borrowernumber);
Looks books up in the reserves. C<$biblionumber> is the biblionumber
of the book to look up. C<$borrowernumber> is the borrower number of a
@@ -92,179 +308,171 @@
that patron's reserves. If neither is specified, C<&FindReserves>
barfs.
-C<&FindReserves> returns a two-element array:
+For each book thus found, C<&FindReserves> checks the reserve
+constraints and does something I don't understand.
-C<$count> is the number of elements in C<$results>.
+C<&FindReserves> returns a two-element array:
-C<$results> is a reference-to-array; each element is a
-reference-to-hash, whose keys are (I think) all of the fields of the
-reserves, borrowers, and biblio tables of the Koha database.
+C<$results> is a reference to an array of references of hashes. Each hash
+has for keys a list of column from reserves table (see details in function).
=cut
+
#'
sub FindReserves {
- my ($bib, $bor) = @_;
- my @params;
-
+ my ( $biblionumber, $bor ) = @_;
my $dbh = C4::Context->dbh;
+ my @bind;
+
# Find the desired items in the reserves
- my $query="SELECT *, reserves.branchcode, reserves.timestamp as rtimestamp, DATE_FORMAT(reserves.timestamp, '%T') AS time
- FROM reserves,borrowers,items ";
- if ($bib ne ''){
- #$bib = $dbh->quote($bib);
- if ($bor ne ''){
- # Both $bib and $bor specified
- # Find a particular book for a particular patron
- #$bor = $dbh->quote($bor);
- $query .= "WHERE (reserves.biblionumber = ?) and
- (borrowers.borrowernumber = ?) and
- (reserves.borrowernumber = borrowers.borrowernumber) and
- (reserves.itemnumber=items.itemnumber) and
- (cancellationdate IS NULL) and
- (found <> 1) ";
-
- push @params, $bib, $bor;
- } else {
- # $bib specified, but not $bor
- # Find a particular book for all patrons
- $query .= "WHERE (reserves.borrowernumber = borrowers.borrowernumber) and
- (reserves.biblionumber = ?) and
- (reserves.itemnumber=items.itemnumber) and
- (cancellationdate IS NULL) and
- (found <> 1) ";
-
- push @params, $bib;
- }
- } else {
- $query .= "WHERE (reserves.biblionumber = items.biblionumber) and
- (borrowers.borrowernumber = ?) and
- (reserves.borrowernumber = borrowers.borrowernumber) and
- (reserves.itemnumber=items.itemnumber) and
- (cancellationdate IS NULL) and
- (found <> 1)";
+ my $query = qq/
+ SELECT branchcode,
+ timestamp AS rtimestamp,
+ priority,
+ biblionumber,
+ borrowernumber,
+ reservedate,
+ constrainttype,
+ found,
+ itemnumber
+ FROM reserves
+ WHERE cancellationdate IS NULL
+ AND (found <> \'F\' OR found IS NULL)
+ /;
- push @params, $bor;
+ if ( $biblionumber ne '' ) {
+ $query .= '
+ AND biblionumber = ?
+ ';
+ push @bind, $biblionumber;
}
- $query.=" order by reserves.timestamp";
- my $sth = $dbh->prepare($query);
- $sth->execute(@params);
- my $i = 0;
+ if ( $bor ne '' ) {
+ $query .= '
+ AND borrowernumber = ?
+ ';
+ push @bind, $bor;
+ }
+
+ $query .= '
+ ORDER BY priority
+ ';
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
my @results;
- while (my $data = $sth->fetchrow_hashref){
- my ($bibdata) =XMLgetbibliohash($dbh,$data->{'biblionumber'});
- my ($itemhash)=XMLgetitemhash($dbh,$data->{'itemnumber'});
- $data->{'holdingbranch'}=XML_readline_onerecord($itemhash,"holdingbranch","holdings");
- $data->{'author'} =XML_readline_onerecord($bibdata,"author","biblios");
- $data->{'publishercode'} = XML_readline_onerecord($bibdata,"publishercode","biblios");
- $data->{'publicationyear'} = XML_readline_onerecord($bibdata,"publicationyear","biblios");
- $data->{'title'} = XML_readline_onerecord($bibdata,"title","biblios");
- push @results, $data;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ # FIXME - What is this if-statement doing? How do constraints work?
+ if ( $data->{constrainttype} eq 'o' ) {
+ $query = '
+ SELECT biblioitemnumber
+ FROM reserveconstraints
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?
+ ';
+ my $csth = $dbh->prepare($query);
+ $csth->execute( $data->{biblionumber}, $data->{borrowernumber},
+ $data->{reservedate}, );
+
+ my @bibitemno;
+ while ( my $bibitemnos = $csth->fetchrow_array ) {
+ push( @bibitemno, $bibitemnos );
+ }
+ my $count = @bibitemno;
+
+ # if we have two or more different specific itemtypes
+ # reserved by same person on same day
+ my $bdata;
+ if ( $count > 1 ) {
+ $bdata = GetBiblioItemData( $bibitemno[$i] );
$i++;
}
+ else {
+
+ # Look up the book we just found.
+ $bdata = GetBiblioItemData( $bibitemno[0] );
+ }
+ $csth->finish;
+
+ # Add the results of this latest search to the current
+ # results.
+ # FIXME - An 'each' would probably be more efficient.
+ foreach my $key ( keys %$bdata ) {
+ $data->{$key} = $bdata->{$key};
+ }
+ }
+ push @results, $data;
+ }
$sth->finish;
- return($i,\@results);
+ return ( $#results + 1, \@results );
}
-=item FindAllReserves
+#-------------------------------------------------------------------------------------
- ($count, $results) = &FindAllReserves($biblionumber, $borrowernumber);
+=item CountReservesFromBorrower
-Looks books up in the reserves. C<$biblionumber> is the biblionumber
-of the book to look up. C<$borrowernumber> is the borrower number of a
-patron whose books to look up.
+$number = &CountReservesFromBorrower($borrowernumber);
-Either C<$biblionumber> or C<$borrowernumber> may be the empty string,
-but not both. If both are specified, C<&FindReserves> looks up the
-given book for the given patron. If only C<$biblionumber> is
-specified, C<&FindReserves> looks up that book for all patrons. If
-only C<$borrowernumber> is specified, C<&FindReserves> looks up all of
-that patron's reserves. If neither is specified, C<&FindReserves>
-barfs.
+this function returns the number of reservation for a borrower given on input arg.
-C<&FindAllReserves> returns a two-element array:
+=cut
-C<$count> is the number of elements in C<$results>.
+sub CountReservesFromBorrower {
+ my ($borrowernumber) = @_;
-C<$results> is a reference-to-array; each element is a
-reference-to-hash, whose keys are (I think) all of the fields of the
-reserves, borrowers, and biblio tables of the Koha database.
+ my $dbh = C4::Context->dbh;
+
+ my $query = '
+ SELECT COUNT(*) AS counter
+ FROM reserves
+ WHERE borrowernumber = ?
+ AND cancellationdate IS NULL
+ AND (found != \'F\' OR found IS NULL)
+ ';
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber);
+ my $row = $sth->fetchrow_hashref;
+ $sth->finish;
+
+ return $row->{counter};
+}
+
+#-------------------------------------------------------------------------------------
+
+=item GetFirstReserveDateFromItem
+
+$date = GetFirstReserveDateFromItem($itemnumber)
+
+this function returns the first date a item has been reserved.
=cut
-#'
-sub FindAllReserves {
- my ($bib, $bor) = @_;
- my @params;
-my $dbh;
+sub GetFirstReserveDateFromItem {
+ my ($itemnumber) = @_;
- $dbh = C4::Context->dbh;
+ my $dbh = C4::Context->dbh;
- # Find the desired items in the reserves
- my $query="SELECT *,
- reserves.branchcode,
- biblio.title AS btitle,
- reserves.timestamp as rtimestamp,
- DATE_FORMAT(reserves.timestamp, '%T') AS time
- FROM reserves,
- borrowers,
- biblio ";
- if ($bib ne ''){
- #$bib = $dbh->quote($bib);
- if ($bor ne ''){
- # Both $bib and $bor specified
- # Find a particular book for a particular patron
- #$bor = $dbh->quote($bor);
- $query .= "WHERE (reserves.biblionumber = ?) and
- (borrowers.borrowernumber = ?) and
- (reserves.borrowernumber = borrowers.borrowernumber) and
- (biblio.biblionumber = ?) and
- (cancellationdate IS NULL) and
- (found <> 1) and
- (reservefrom > NOW())";
- push @params, $bib, $bor, $bib;
- } else {
- # $bib specified, but not $bor
- # Find a particular book for all patrons
- $query .= "WHERE (reserves.borrowernumber = borrowers.borrowernumber) and
- (biblio.biblionumber = ?) and
- (reserves.biblionumber = ?) and
- (cancellationdate IS NULL) and
- (found <> 1) and
- (reservefrom > NOW())";
- push @params, $bib, $bib;
- }
- } else {
- $query .= "WHERE (reserves.biblionumber = biblio.biblionumber) and
- (borrowers.borrowernumber = ?) and
- (reserves.borrowernumber = borrowers.borrowernumber) and
- (reserves.biblionumber = biblio.biblionumber) and
- (cancellationdate IS NULL) and
- (found <> 1) and
- (reservefrom > NOW())";
- push @params, $bor;
- }
- $query.=" order by reserves.timestamp";
+ my $query = '
+ SELECT reservedate,
+ borrowernumber,
+ branchcode
+ FROM reserves
+ WHERE itemnumber = ?
+ AND cancellationdate IS NULL
+ AND (found != \'F\' OR found IS NULL)
+ ';
my $sth = $dbh->prepare($query);
- $sth->execute(@params);
-
- my $i = 0;
- my @results;
- while (my $data = $sth->fetchrow_hashref){
- my $bibdata = C4::Search::bibdata($data->{'biblionumber'});
- $data->{'author'} = $bibdata->{'author'};
- $data->{'publishercode'} = $bibdata->{'publishercode'};
- $data->{'publicationyear'} = $bibdata->{'publicationyear'};
- $data->{'title'} = $bibdata->{'title'};
- push @results, $data;
- $i++;
- }
- $sth->finish;
+ $sth->execute($itemnumber);
+ my $row = $sth->fetchrow_hashref;
- return($i,\@results);
+ return ($row->{reservedate},$row->{borrowernumber},$row->{branchcode});
}
+#-------------------------------------------------------------------------------------
+
=item CheckReserves
($status, $reserve) = &CheckReserves($itemnumber, $barcode);
@@ -295,31 +503,50 @@
table in the Koha database.
=cut
+
#'
sub CheckReserves {
- my ($item, $barcode) = @_;
-# warn "In CheckReserves: itemnumber = $item";
+ my ( $item, $barcode ) = @_;
my $dbh = C4::Context->dbh;
my $sth;
if ($item) {
-
- } else {
- my $qbc=$dbh->quote($barcode);
+ my $qitem = $dbh->quote($item);
+ # Look up the item by itemnumber
+ my $query = qq(
+ SELECT items.biblionumber, items.biblioitemnumber, itemtypes.notforloan
+ FROM items, biblioitems, itemtypes
+ WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
+ AND biblioitems.itemtype = itemtypes.itemtype
+ AND itemnumber=$qitem
+ );
+ $sth = $dbh->prepare($query);
+ }
+ else {
+ my $qbc = $dbh->quote($barcode);
# Look up the item by barcode
- $sth=$dbh->prepare("SELECT items.itemnumber
- FROM items
- WHERE barcode=$qbc");
+ my $query = qq(
+ SELECT items.biblionumber, items.biblioitemnumber, itemtypes.notforloan
+ FROM items, biblioitems, itemtypes
+ WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
+ AND biblioitems.itemtype = itemtypes.itemtype
+ AND barcode=$qbc
+ );
+ $sth = $dbh->prepare($query);
+
+ # FIXME - This function uses $item later on. Ought to set it here.
+ }
$sth->execute;
- ($item) = $sth->fetchrow;
+ my ( $biblio, $bibitem, $notforloan ) = $sth->fetchrow_array;
$sth->finish;
- }
+ # if item is not for loan it cannot be reserved either.....
+ return ( 0, 0 ) if $notforloan;
-# if item is not for loan it cannot be reserved either.....
-# return (0, 0) if ($notforloan);
-# get the reserves...
+ # get the reserves...
# Find this item in the reserves
- my ($count, @reserves) = Findgroupreserve($item);
+ my @reserves = Findgroupreserve( $bibitem, $biblio );
+ my $count = scalar @reserves;
+
# $priority and $highest are used to find the most important item
# in the list returned by &Findgroupreserve. (The lower $priority,
# the more important the item.)
@@ -328,12 +555,17 @@
my $highest;
if ($count) {
foreach my $res (@reserves) {
- if ($res->{found} eq "W"){
- return ("Waiting", $res);
- }else{
+ # FIXME - $item might be undefined or empty: the caller
+ # might be searching by barcode.
+ if ( $res->{'itemnumber'} == $item ) {
+ # Found it
+ return ( "Waiting", $res );
+ }
+ else {
# See if this item is more important than what we've got
# so far.
- if ($res->{'priority'} != 0 && $res->{'priority'} < $priority) {
+ if ( $res->{'priority'} != 0 && $res->{'priority'} < $priority )
+ {
$priority = $res->{'priority'};
$highest = $res;
}
@@ -346,266 +578,481 @@
# next in line to get this book.
if ($highest) { # FIXME - $highest might be undefined
$highest->{'itemnumber'} = $item;
- return ("Reserved", $highest);
- } else {
- return (0, 0);
+ return ( "Reserved", $highest );
+ }
+ else {
+ return ( 0, 0 );
}
}
+#-------------------------------------------------------------------------------------
+
=item CancelReserve
- &CancelReserve($reserveid);
+ &CancelReserve($biblionumber, $itemnumber, $borrowernumber);
Cancels a reserve.
-Use reserveid to cancel the reservation.
+Use either C<$biblionumber> or C<$itemnumber> to specify the item to
+cancel, but not both: if both are given, C<&CancelReserve> does
+nothing.
+
+C<$borrowernumber> is the borrower number of the patron on whose
+behalf the book was reserved.
-C<$reserveid> is the reserve ID to cancel.
+If C<$biblionumber> was given, C<&CancelReserve> also adjusts the
+priorities of the other people who are waiting on the book.
=cut
+
#'
sub CancelReserve {
- my ($biblio, $item, $borr) = @_;
-
-my $dbh;
-
- $dbh = C4::Context->dbh;
-
- #warn "In CancelReserve";
- if (($item and $borr) and (not $biblio)) {
+ my ( $biblio, $item, $borr ) = @_;
+ my $dbh = C4::Context->dbh;
+ if ( ( $item and $borr ) and ( not $biblio ) ) {
# removing a waiting reserve record....
# update the database...
- my $sth = $dbh->prepare("update reserves set cancellationdate = now(),
+ my $query = qq/
+ UPDATE reserves
+ SET cancellationdate = now(),
found = Null,
priority = 0
- where itemnumber = ?
- and borrowernumber = ?");
- $sth->execute($item,$borr);
+ WHERE itemnumber = ?
+ AND borrowernumber = ?
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $item, $borr );
$sth->finish;
}
- if (($biblio and $borr) and (not $item)) {
+ if ( ( $biblio and $borr ) and ( not $item ) ) {
# removing a reserve record....
# get the prioritiy on this record....
my $priority;
- my $sth=$dbh->prepare("SELECT priority FROM reserves
+ my $query = qq/
+ SELECT priority FROM reserves
WHERE biblionumber = ?
AND borrowernumber = ?
- AND cancellationdate is NULL
- AND (found <> 1 )");
- $sth->execute($biblio,$borr);
+ AND cancellationdate IS NULL
+ AND itemnumber IS NULL
+ AND (found <> 'F' OR found IS NULL)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $borr );
($priority) = $sth->fetchrow_array;
$sth->finish;
+ $query = qq/
+ UPDATE reserves
+ SET cancellationdate = now(),
+ found = Null,
+ priority = 0
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND cancellationdate IS NULL
+ AND (found <> 'F' or found IS NULL)
+ /;
# update the database, removing the record...
- $sth = $dbh->prepare("update reserves set cancellationdate = now(),
- found = 0,
- priority = 0
- where biblionumber = ?
- and borrowernumber = ?
- and cancellationdate is NULL
- and (found <> 1 )");
- $sth->execute($biblio,$borr);
+ $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $borr );
$sth->finish;
+
# now fix the priority on the others....
- fixpriority($priority, $biblio);
+ FixPriority( $priority, $biblio );
}
}
+
+#-------------------------------------------------------------------------------------
+
=item FillReserve
- &FillReserve($reserveid, $itemnumber);
+ &FillReserve($reserve);
Fill a reserve. If I understand this correctly, this means that the
reserved book has been found and given to the patron who reserved it.
-C<$reserve> specifies the reserve id to fill.
-
-C<$itemnumber> specifies the borrowed itemnumber for the reserve.
+C<$reserve> specifies the reserve to fill. It is a reference-to-hash
+whose keys are fields from the reserves table in the Koha database.
=cut
+
#'
sub FillReserve {
my ($res) = @_;
-my $dbh;
- $dbh = C4::Context->dbh;
+ my $dbh = C4::Context->dbh;
# fill in a reserve record....
- # FIXME - Remove some of the redundancy here
- my $biblio = $res->{'biblionumber'}; my $qbiblio =$biblio;
+ my $qbiblio = $res->{'biblionumber'};
my $borr = $res->{'borrowernumber'};
my $resdate = $res->{'reservedate'};
# get the priority on this record....
my $priority;
- {
- my $query = "SELECT priority FROM reserves
+ my $query = "SELECT priority
+ FROM reserves
WHERE biblionumber = ?
AND borrowernumber = ?
AND reservedate = ?";
- my $sth=$dbh->prepare($query);
- $sth->execute($qbiblio,$borr,$resdate);
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $qbiblio, $borr, $resdate );
($priority) = $sth->fetchrow_array;
$sth->finish;
- }
# update the database...
- {
- my $query = "UPDATE reserves SET found = 1,
+ $query = "UPDATE reserves
+ SET found = 'F',
priority = 0
WHERE biblionumber = ?
AND reservedate = ?
- AND borrowernumber = ?";
- my $sth = $dbh->prepare($query);
- $sth->execute($qbiblio,$resdate,$borr);
+ AND borrowernumber = ?
+ ";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $qbiblio, $resdate, $borr );
$sth->finish;
- }
# now fix the priority on the others (if the priority wasn't
# already sorted!)....
- unless ($priority == 0) {
- fixpriority($priority, $biblio);
+ unless ( $priority == 0 ) {
+ FixPriority( $priority, $qbiblio );
}
}
-# Only used internally
-# Decrements (makes more important) the reserves for all of the
-# entries waiting on the given book, if their priority is > $priority.
-sub fixpriority {
- my ($priority, $biblio) = @_;
-my $dbh;
- $dbh = C4::Context->dbh;
+#-------------------------------------------------------------------------------------
+
+=item FixPriority
+
+&FixPriority($biblio,$borrowernumber,$rank);
+
+ Only used internally (so don't export it)
+ Changed how this functions works #
+ Now just gets an array of reserves in the rank order and updates them with
+ the array index (+1 as array starts from 0)
+ and if $rank is supplied will splice item from the array and splice it back in again
+ in new priority rank
+
+=cut
+
+sub FixPriority {
+ my ( $biblio, $borrowernumber, $rank ) = @_;
+ my $dbh = C4::Context->dbh;
+ if ( $rank eq "del" ) {
+ CancelReserve( $biblio, undef, $borrowernumber );
+ }
+ if ( $rank eq "W" || $rank eq "0" ) {
- my ($count, $reserves) = FindReserves($biblio);
- foreach my $rec (@$reserves) {
- if ($rec->{'priority'} > $priority) {
- my $sth = $dbh->prepare("UPDATE reserves SET priority = ?
+ # make sure priority for waiting items is 0
+ my $query = qq/
+ UPDATE reserves
+ SET priority = 0
WHERE biblionumber = ?
AND borrowernumber = ?
- AND reservedate = ?");
- $sth->execute($rec->{'priority'},$rec->{'biblionumber'},$rec->{'borrowernumber'},$rec->{'reservedate'});
- $sth->finish;
+ AND cancellationdate IS NULL
+ AND found ='W'
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $borrowernumber );
+ }
+ my @priority;
+ my @reservedates;
+
+ # get whats left
+# FIXME adding a new security in returned elements for changing priority,
+# now, we don't care anymore any reservations with itemnumber linked (suppose a waiting reserve)
+ my $query = qq/
+ SELECT borrowernumber, reservedate, constrainttype
+ FROM reserves
+ WHERE biblionumber = ?
+ AND cancellationdate IS NULL
+ AND itemnumber IS NULL
+ AND ((found <> 'F' and found <> 'W') or found is NULL)
+ ORDER BY priority ASC
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($biblio);
+ while ( my $line = $sth->fetchrow_hashref ) {
+ push( @reservedates, $line );
+ push( @priority, $line );
+ }
+
+ # To find the matching index
+ my $i;
+ my $key = -1; # to allow for 0 to be a valid result
+ for ( $i = 0 ; $i < @priority ; $i++ ) {
+ if ( $borrowernumber == $priority[$i]->{'borrowernumber'} ) {
+ $key = $i; # save the index
+ last;
}
}
+
+ # if index exists in array then move it to new position
+ if ( $key > -1 && $rank ne 'del' && $rank > 0 ) {
+ my $new_rank = $rank -
+ 1; # $new_rank is what you want the new index to be in the array
+ my $moving_item = splice( @priority, $key, 1 );
+ splice( @priority, $new_rank, 0, $moving_item );
+ }
+
+ # now fix the priority on those that are left....
+ $query = "
+ UPDATE reserves
+ SET priority = ?
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?
+ AND found IS NULL
+ ";
+ $sth = $dbh->prepare($query);
+ for ( my $j = 0 ; $j < @priority ; $j++ ) {
+ $sth->execute(
+ $j + 1, $biblio,
+ $priority[$j]->{'borrowernumber'},
+ $priority[$j]->{'reservedate'}
+ );
+ $sth->finish;
+ }
}
-# XXX - POD
-sub ReserveWaiting {
- my ($item, $borr) = @_;
+#-------------------------------------------------------------------------------------
+
+=item ReserveWaiting
-my $dbh;
+branchcode = &ReserveWaiting($item,$borr);
+this function set FOUND to 'W' for Waiting into the database.
- $dbh = C4::Context->dbh;
+=cut
-# get priority and biblionumber....
- my $sth = $dbh->prepare("SELECT reserves.priority as priority,
+sub ReserveWaiting {
+ my ( $item, $borr,$diffBranchSend ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # get priority and biblionumber....
+ my $query = qq/
+ SELECT reserves.priority as priority,
reserves.biblionumber as biblionumber,
reserves.branchcode as branchcode,
reserves.timestamp as timestamp
- FROM reserves
- WHERE reserves.itemnumber = ?
+ FROM reserves,items
+ WHERE reserves.biblionumber = items.biblionumber
+ AND items.itemnumber = ?
AND reserves.borrowernumber = ?
- AND reserves.cancellationdate is NULL
- AND (reserves.found <> '1' or reserves.found is NULL)");
- $sth->execute($item,$borr);
+ AND reserves.cancellationdate IS NULL
+ AND (reserves.found <> 'F' OR reserves.found IS NULL)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $item, $borr );
my $data = $sth->fetchrow_hashref;
$sth->finish;
my $biblio = $data->{'biblionumber'};
my $timestamp = $data->{'timestamp'};
-# update reserves record....
- $sth = $dbh->prepare("UPDATE reserves SET priority = 0, found = 'W'
+
+ # update reserves record....
+ if ($diffBranchSend) {
+ $query = qq/
+ UPDATE reserves
+ SET priority = 0,
+ itemnumber = ?
WHERE borrowernumber = ?
- AND itemnumber = ?
- AND timestamp = ?");
- $sth->execute($borr,$item,$timestamp);
+ AND biblionumber = ?
+ AND timestamp = ?
+ /;
+ }
+ else {
+ $query = qq/
+ UPDATE reserves
+ SET priority = 0,
+ found = 'W',
+ waitingdate=now(),
+ itemnumber = ?
+ WHERE borrowernumber = ?
+ AND biblionumber = ?
+ AND timestamp = ?
+ /;
+ }
+ $sth = $dbh->prepare($query);
+ $sth->execute( $item, $borr, $biblio, $timestamp );
$sth->finish;
-# now fix up the remaining priorities....
- fixpriority($data->{'priority'}, $biblio);
+
+ # now fix up the remaining priorities....
+ FixPriority( $data->{'priority'}, $biblio );
my $branchcode = $data->{'branchcode'};
return $branchcode;
}
-# XXX - POD
-sub CheckWaiting {
- my ($borr)=@_;
+#-------------------------------------------------------------------------------------
+
+=item GetWaitingReserves
+
+\@itemswaiting=GetWaitingReserves($borr);
+
+this funtion fetch the list of waiting reserves from database.
+
+=cut
-my $dbh;
- $dbh = C4::Context->dbh;
+sub GetWaitingReserves {
+ my ($borr) = @_;
+ my $dbh = C4::Context->dbh;
my @itemswaiting;
- my $sth = $dbh->prepare("SELECT * FROM reserves
+ my $query = qq/
+ SELECT *
+ FROM reserves
WHERE borrowernumber = ?
AND reserves.found = 'W'
- AND cancellationdate is NULL");
+ AND cancellationdate IS NULL
+ /;
+ my $sth = $dbh->prepare($query);
$sth->execute($borr);
- while (my $data=$sth->fetchrow_hashref) {
- push(@itemswaiting,$data);
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @itemswaiting, $data );
}
$sth->finish;
- return (scalar(@itemswaiting),\@itemswaiting);
+ return \@itemswaiting;
}
+#-------------------------------------------------------------------------------------
+
=item Findgroupreserve
- ($count, @results) = &Findgroupreserve($biblioitemnumber, $biblionumber);
+ @results = &Findgroupreserve($biblioitemnumber, $biblionumber);
+****** FIXME ******
I don't know what this does, because I don't understand how reserve
constraints work. I think the idea is that you reserve a particular
biblio, and the constraint allows you to restrict it to a given
biblioitem (e.g., if you want to borrow the audio book edition of "The
Prophet", rather than the first available publication).
-C<&Findgroupreserve> returns a two-element array:
-
-C<$count> is the number of elements in C<@results>.
-
+C<&Findgroupreserve> returns :
C<@results> is an array of references-to-hash whose keys are mostly
fields from the reserves table of the Koha database, plus
C<biblioitemnumber>.
=cut
+
#'
sub Findgroupreserve {
- my ($itemnumber)=@_;
-
-my $dbh = C4::Context->dbh;
-
- my $sth = $dbh->prepare("SELECT *
+ my ( $bibitem, $biblio ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ SELECT reserves.biblionumber AS biblionumber,
+ reserves.borrowernumber AS borrowernumber,
+ reserves.reservedate AS reservedate,
+ reserves.branchcode AS branchcode,
+ reserves.cancellationdate AS cancellationdate,
+ reserves.found AS found,
+ reserves.reservenotes AS reservenotes,
+ reserves.priority AS priority,
+ reserves.timestamp AS timestamp,
+ reserveconstraints.biblioitemnumber AS biblioitemnumber,
+ reserves.itemnumber AS itemnumber
FROM reserves
- WHERE (itemnumber = ?) AND
- (cancellationdate IS NULL) AND
- (found <> 1)
- ORDER BY timestamp");
- $sth->execute($itemnumber);
+ LEFT JOIN reserveconstraints ON reserves.biblionumber = reserveconstraints.biblionumber
+ WHERE reserves.biblionumber = ?
+ AND ( ( reserveconstraints.biblioitemnumber = ?
+ AND reserves.borrowernumber = reserveconstraints.borrowernumber
+ AND reserves.reservedate =reserveconstraints.reservedate )
+ OR reserves.constrainttype='a' )
+ AND reserves.cancellationdate is NULL
+ AND (reserves.found <> 'F' or reserves.found is NULL)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $bibitem );
my @results;
- while (my $data = $sth->fetchrow_hashref) {
- push(@results,$data);
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
}
$sth->finish;
- return(scalar(@results), at results);
+ return @results;
}
-# FIXME - A somewhat different version of this function appears in
-# C4::Reserves. Pick one and stick with it.
-# XXX - POD
-sub CreateReserve {
- my ($env, $borrnum,$registeredby ,$biblionumber,$reservefrom, $reserveto, $branch,
- $constraint, $priority, $notes, $title,$bibitems,$itemnumber) = @_;
+=item CreateReserve
+
+CreateReserve($env,$branch,$borrowernumber,$biblionumber,$constraint,$bibitems,$priority,$notes,$title,$checkitem,$found)
-my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("INSERT INTO reserves
- (borrowernumber, registeredby, reservedate, biblionumber, reservefrom,
- reserveto, branchcode, constrainttype, priority, found, reservenotes,itemnumber)
- VALUES (?, ?, NOW(),?,?,?,?,?,?,0,?,?)");
- $sth->execute($borrnum, $registeredby, $biblionumber, $reservefrom, $reserveto, $branch, $constraint, $priority, $notes,$itemnumber);
-my $fee=CalcReserveFee($env,$borrnum,$biblionumber,$constraint,$bibitems);
- if ($fee > 0) {
+FIXME - A somewhat different version of this function appears in
+C4::Reserves. Pick one and stick with it.
- my $nextacctno = &getnextacctno($env,$borrnum,$dbh);
- my $usth = $dbh->prepare("insert into accountlines
+=cut
+
+sub CreateReserve {
+ my (
+ $env, $branch, $borrowernumber, $biblionumber,
+ $constraint, $bibitems, $priority, $notes,
+ $title, $checkitem, $found
+ ) = @_;
+ my $fee;
+ if ( $library_name =~ /Horowhenua/ ) {
+ $fee =
+ CalcHLTReserveFee( $env, $borrowernumber, $biblionumber, $constraint,
+ $bibitems );
+ }
+ else {
+ $fee =
+ CalcReserveFee( $env, $borrowernumber, $biblionumber, $constraint,
+ $bibitems );
+ }
+ my $dbh = C4::Context->dbh;
+ my $const = lc substr( $constraint, 0, 1 );
+ my @datearr = localtime(time);
+ my $resdate =
+ ( 1900 + $datearr[5] ) . "-" . ( $datearr[4] + 1 ) . "-" . $datearr[3];
+ my $waitingdate;
+
+ # If the reserv had the waiting status, we had the value of the resdate
+ if ( $found eq 'W' ) {
+ $waitingdate = $resdate;
+ }
+
+ #eval {
+ # updates take place here
+ if ( $fee > 0 ) {
+ my $nextacctno = &getnextacctno( $env, $borrowernumber, $dbh );
+ my $query = qq/
+ INSERT INTO accountlines
(borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
- values
- (?,?,now(),?,?,'Res',?)");
- $usth->execute($borrnum,$nextacctno,$fee,'Reserve Charge -'. $title,$fee);
+ VALUES
+ (?,?,now(),?,?,'Res',?)
+ /;
+ my $usth = $dbh->prepare($query);
+ $usth->execute( $borrowernumber, $nextacctno, $fee,
+ "Reserve Charge - $title", $fee );
$usth->finish;
}
- return 1;
+
+ #if ($const eq 'a'){
+ my $query = qq/
+ INSERT INTO reserves
+ (borrowernumber,biblionumber,reservedate,branchcode,constrainttype,
+ priority,reservenotes,itemnumber,found,waitingdate)
+ VALUES
+ (?,?,?,?,?,
+ ?,?,?,?,?)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $borrowernumber, $biblionumber, $resdate, $branch,
+ $const, $priority, $notes, $checkitem,
+ $found, $waitingdate
+ );
+ $sth->finish;
+
+ #}
+ if ( ( $const eq "o" ) || ( $const eq "e" ) ) {
+ my $numitems = @$bibitems;
+ my $i = 0;
+ while ( $i < $numitems ) {
+ my $biblioitem = @$bibitems[$i];
+ my $query = qq/
+ INSERT INTO reserveconstraints
+ (borrowernumber,biblionumber,reservedate,biblioitemnumber)
+ VALUES
+ (?,?,?,?)
+ /;
+ my $sth = $dbh->prepare("");
+ $sth->execute( $borrowernumber, $biblionumber, $resdate,
+ $biblioitem );
+ $sth->finish;
+ $i++;
+ }
+ }
+ return;
}
# FIXME - A functionally identical version of this function appears in
@@ -614,149 +1061,334 @@
# FIXME - opac-reserves.pl need to use it, temporarily put into @EXPORT
sub CalcReserveFee {
- my ($env,$borrnum,$biblionumber,$constraint,$bibitems) = @_;
- #check for issues;
-my $dbh = C4::Context->dbh;
-
+ my ( $env, $borrowernumber, $biblionumber, $constraint, $bibitems ) = @_;
- my $const = lc substr($constraint,0,1);
- my $sth = $dbh->prepare("SELECT * FROM borrowers,categories
- WHERE (borrowernumber = ?)
- AND (borrowers.categorycode = categories.categorycode)");
- $sth->execute($borrnum);
+ #check for issues;
+ my $dbh = C4::Context->dbh;
+ my $const = lc substr( $constraint, 0, 1 );
+ my $query = qq/
+ SELECT * FROM borrowers,categories
+ WHERE borrowernumber = ?
+ AND borrowers.categorycode = categories.categorycode
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber);
my $data = $sth->fetchrow_hashref;
$sth->finish();
my $fee = $data->{'reservefee'};
+ my $cntitems = @- > $bibitems;
- if ($fee > 0) {
- # check for items on issue
-
+ if ( $fee > 0 ) {
+ # check for items on issue
+ # first find biblioitem records
+ my @biblioitems;
+ my $sth1 = $dbh->prepare(
+ "SELECT * FROM biblio,biblioitems
+ WHERE (biblio.biblionumber = ?)
+ AND (biblio.biblionumber = biblioitems.biblionumber)"
+ );
+ $sth1->execute($biblionumber);
+ while ( my $data1 = $sth1->fetchrow_hashref ) {
+ if ( $const eq "a" ) {
+ push @biblioitems, $data1;
+ }
+ else {
+ my $found = 0;
+ my $x = 0;
+ while ( $x < $cntitems ) {
+ if ( @$bibitems->{'biblioitemnumber'} ==
+ $data->{'biblioitemnumber'} )
+ {
+ $found = 1;
+ }
+ $x++;
+ }
+ if ( $const eq 'o' ) {
+ if ( $found == 1 ) {
+ push @biblioitems, $data1;
+ }
+ }
+ else {
+ if ( $found == 0 ) {
+ push @biblioitems, $data1;
+ }
+ }
+ }
+ }
+ $sth1->finish;
+ my $cntitemsfound = @biblioitems;
my $issues = 0;
my $x = 0;
my $allissued = 1;
-
- my $sth2 = $dbh->prepare("SELECT * FROM items
- WHERE biblionumber = ?");
- $sth2->execute($biblionumber);
- while (my $itdata=$sth2->fetchrow_hashref) {
- my $sth3 = $dbh->prepare("SELECT * FROM issues
+ while ( $x < $cntitemsfound ) {
+ my $bitdata = $biblioitems[$x];
+ my $sth2 = $dbh->prepare(
+ "SELECT * FROM items
+ WHERE biblioitemnumber = ?"
+ );
+ $sth2->execute( $bitdata->{'biblioitemnumber'} );
+ while ( my $itdata = $sth2->fetchrow_hashref ) {
+ my $sth3 = $dbh->prepare(
+ "SELECT * FROM issues
WHERE itemnumber = ?
- AND returndate IS NULL");
- $sth3->execute($itdata->{'itemnumber'});
- if (my $isdata=$sth3->fetchrow_hashref) {
- } else {
+ AND returndate IS NULL"
+ );
+ $sth3->execute( $itdata->{'itemnumber'} );
+ if ( my $isdata = $sth3->fetchrow_hashref ) {
+ }
+ else {
$allissued = 0;
}
}
-
-
- if ($allissued == 0) {
- my $rsth = $dbh->prepare("SELECT * FROM reserves WHERE biblionumber = ?");
+ $x++;
+ }
+ if ( $allissued == 0 ) {
+ my $rsth =
+ $dbh->prepare("SELECT * FROM reserves WHERE biblionumber = ?");
$rsth->execute($biblionumber);
- if (my $rdata = $rsth->fetchrow_hashref) {
- } else {
+ if ( my $rdata = $rsth->fetchrow_hashref ) {
+ }
+ else {
$fee = 0;
}
}
}
-# print "fee $fee";
+ # print "fee $fee";
return $fee;
}
-# XXX - Internal use
-sub getnextacctno {
- my ($env,$bornumber,$dbh)=@_;
+# The following are junior and young adult item types that should not incur a
+# reserve charge.
+#
+# Juniors: BJC, BJCN, BJF, BJK, BJM, BJN, BJP, BJSF, BJSN, DJ, DJP, FJ, JVID,
+# VJ, VJP, PJ, TJ, TJP, VJ, VJP.
+#
+# Young adults: BYF, BYN, BYP, DY, DYP, PY, PYP, TY, TYP, VY, VYP.
+#
+# All other item types should incur a reserve charge.
+sub CalcHLTReserveFee {
+ my ( $env, $borrowernumber, $biblionumber, $constraint, $bibitems ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "SELECT * FROM borrowers,categories
+ WHERE (borrowernumber = ?)
+ AND (borrowers.categorycode = categories.categorycode)"
+ );
+ $sth->execute($borrowernumber);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish();
+ my $fee = $data->{'reservefee'};
+
+ my $matchno;
+ my @nocharge =
+ qw/BJC BJCN BJF BJK BJM BJN BJP BJSF BJSN DJ DJP FJ NJ CJ VJ VJP PJ TJ TJP BYF BYN BYP DY DYP PY PYP TY TYP VY VYP/;
+ $sth = $dbh->prepare(
+ "SELECT * FROM biblio,biblioitems
+ WHERE (biblio.biblionumber = ?)
+ AND (biblio.biblionumber = biblioitems.biblionumber)"
+ );
+ $sth->execute($biblionumber);
+ $data = $sth->fetchrow_hashref;
+ my $itemtype = $data->{'itemtype'};
+ for ( my $i = 0 ; $i < @nocharge ; $i++ ) {
+ if ( $itemtype eq $nocharge[$i] ) {
+ $matchno++;
+ last;
+ }
+ }
+
+ if ( $matchno > 0 ) {
+ $fee = 0;
+ }
+ return $fee;
+}
+
+=item GetNextAccountNumber
+
+GetNextAccountNumber()
+
+=cut
+
+sub GetNextAccountNumber {
+ my ( $env, $borrowernumber, $dbh ) = @_;
my $nextaccntno = 1;
- my $sth = $dbh->prepare("select * from accountlines
+ my $sth = $dbh->prepare(
+ "select * from accountlines
where (borrowernumber = ?)
- order by accountno desc");
- $sth->execute($bornumber);
- if (my $accdata=$sth->fetchrow_hashref){
+ order by accountno desc"
+ );
+ $sth->execute($borrowernumber);
+ if ( my $accdata = $sth->fetchrow_hashref ) {
$nextaccntno = $accdata->{'accountno'} + 1;
}
$sth->finish;
- return($nextaccntno);
+ return ($nextaccntno);
}
-# XXX - POD
-sub UpdateReserves {
+#-------------------------------------------------------------------------------------
+
+=item UpdateReserve
+
+&UpdateReserve($rank,$biblio,$borrower,$branch)
+
+=cut
+
+sub UpdateReserve {
#subroutine to update a reserve
- my ($rank,$biblio,$borrower,$branch,$cataloger)=@_;
+ my ( $rank, $biblio, $borrower, $branch , $itemnumber) = @_;
return if $rank eq "W";
return if $rank eq "n";
-my $dbh;
- $dbh = C4::Context->dbh;
-
- if ($rank eq "del") {
- my $sth=$dbh->prepare("UPDATE reserves SET cancellationdate=now(),registeredby=?
+ my $dbh = C4::Context->dbh;
+ if ( $rank eq "del" ) {
+ my $query = qq/
+ UPDATE reserves
+ SET cancellationdate=now()
WHERE biblionumber = ?
AND borrowernumber = ?
AND cancellationdate is NULL
- AND (found <> 1 )");
- $sth->execute($cataloger,$biblio, $borrower);
+ AND (found <> 'F' or found is NULL)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $borrower );
$sth->finish;
- } else {
- my $sth=$dbh->prepare("UPDATE reserves SET priority = ? ,branchcode = ?, found = 0
+
+ }
+ else {
+ my $query = qq/
+ UPDATE reserves SET priority = ? ,branchcode = ?, itemnumber = ?, found = NULL
WHERE biblionumber = ?
AND borrowernumber = ?
AND cancellationdate is NULL
- AND (found <> 1)");
- $sth->execute($rank, $branch, $biblio, $borrower);
+ AND (found <> 'F' or found is NULL)
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $rank, $branch,$itemnumber, $biblio, $borrower);
$sth->finish;
+ FixPriority( $biblio, $borrower, $rank);
}
}
-# XXX - POD
-sub UpdateReserve {
- #subroutine to update a reserve
- my ($reserveid, $timestamp) = @_;
+=item GetReserveTitle
-my $dbh;
- $dbh = C4::Context->dbh;
+$data = GetReserveTitle($biblio,$bor,$date,$timestamp);
+=cut
- my $sth=$dbh->prepare("UPDATE reserves
- SET timestamp = $timestamp,
- reservedate = DATE_FORMAT($timestamp, '%Y-%m-%d')
- WHERE (reserveid = $reserveid)");
- $sth->execute();
+sub GetReserveTitle {
+ my ( $biblio, $bor, $date, $timestamp ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq/
+ SELECT *
+ FROM reserveconstraints,biblioitems
+ WHERE reserveconstraints.biblioitemnumber=biblioitems.biblioitemnumber
+ AND reserveconstraints.biblionumber=?
+ AND reserveconstraints.borrowernumber = ?
+ AND reserveconstraints.reservedate=?
+ AND reserveconstraints.timestamp=?
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblio, $bor, $date, $timestamp );
+ my $data = $sth->fetchrow_hashref;
$sth->finish;
+ return $data;
}
-# XXX - POD
-sub getreservetitle {
- my ($biblio,$bor,$date,$timestamp)=@_;
-my $dbh = C4::Context->dbh;
+=item FindReservesInQueue
+ $results = &FindReservesInQueue($biblionumber);
- my $sth=$dbh->prepare("Select * from reserveconstraints where
- reserveconstraints.biblionumber=? and reserveconstraints.borrowernumber
- = ? and reserveconstraints.reservedate=? and
- reserveconstraints.timestamp=?");
- $sth->execute($biblio,$bor,$date,$timestamp);
- my $data=$sth->fetchrow_hashref;
- $sth->finish;
- return($data);
-}
+Simple variant of FindReserves, exept the result is now displaying only the queue list of reservations with the same biblionumber (At this time only displayed in request.pl)
+
+C<&FindReservesInQueue> returns a two-element array:
+
+C<$results> is a reference to an array of references of hashes. Each hash
+has for keys a list of column from reserves table (see details in function).
+
+=cut
+
+#'
-sub findActiveReserve {
- my ($borrowernumber, $biblionumber, $from, $days) = @_;
-my $dbh = C4::Context->dbh;
+sub FindReservesInQueue {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT *
+ # Find the desired items in the reserves
+ my $query = qq/
+ SELECT branchcode,
+ timestamp AS rtimestamp,
+ priority,
+ biblionumber,
+ borrowernumber,
+ reservedate,
+ constrainttype,
+ found,
+ itemnumber
FROM reserves
- WHERE
- borrowernumber = ?
+ WHERE cancellationdate IS NULL
AND biblionumber = ?
- AND (cancellationdate IS NULL)
- AND (found <> 1)
- AND ((? BETWEEN reservefrom AND reserveto)
- OR (ADDDATE(?, INTERVAL ? DAY) BETWEEN reservefrom AND reserveto))
- ");
- $sth->execute($borrowernumber, $biblionumber, $from, $from, $days);
- return ($sth->rows);
+ AND (found <> \'F\' OR found IS NULL)
+ AND priority <> \'0\'
+ ORDER BY priority
+ /;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($biblionumber);
+ my @results;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ # FIXME - What is this if-statement doing? How do constraints work?
+ if ( $data->{constrainttype} eq 'o' ) {
+ $query = '
+ SELECT biblioitemnumber
+ FROM reserveconstraints
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?
+ ';
+ my $csth = $dbh->prepare($query);
+ $csth->execute( $data->{biblionumber}, $data->{borrowernumber},
+ $data->{reservedate}, );
+
+ my @bibitemno;
+ while ( my $bibitemnos = $csth->fetchrow_array ) {
+ push( @bibitemno, $bibitemnos );
+ }
+ my $count = @bibitemno;
+
+ # if we have two or more different specific itemtypes
+ # reserved by same person on same day
+ my $bdata;
+ if ( $count > 1 ) {
+ $bdata = GetBiblioItemData( $bibitemno[$i] );
+ $i++;
+ }
+ else {
+ # Look up the book we just found.
+ $bdata = GetBiblioItemData( $bibitemno[0] );
+ }
+ $csth->finish;
+
+ # Add the results of this latest search to the current
+ # results.
+ # FIXME - An 'each' would probably be more efficient.
+ foreach my $key ( keys %$bdata ) {
+ $data->{$key} = $bdata->{$key};
+ }
+ }
+ push @results, $data;
+ }
+ $sth->finish;
+
+ return ( $#results + 1, \@results );
}
-1;
\ No newline at end of file
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
+
Index: Review.pm
===================================================================
RCS file: /sources/koha/koha/C4/Review.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- Review.pm 17 Jun 2006 22:28:24 -0000 1.3
+++ Review.pm 9 Mar 2007 14:31:47 -0000 1.4
@@ -23,7 +23,8 @@
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = 0.01;
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.4 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -47,8 +48,6 @@
=head1 FUNCTIONS
-=over 2
-
=cut
@ISA = qw(Exporter);
@@ -99,7 +98,6 @@
my $sth = $dbh->prepare($query);
$sth->execute( $review, 0, $borrowernumber, $biblionumber );
$sth->finish();
-
}
sub numberofreviews {
@@ -151,7 +149,6 @@
Takes a reviewid and marks that review approved
-
=cut
sub approvereview {
@@ -171,7 +168,6 @@
Takes a reviewid and deletes it
-
=cut
sub deletereview {
@@ -187,8 +183,6 @@
1;
__END__
-=back
-
=head1 AUTHOR
Koha Team
Index: Search.pm
===================================================================
RCS file: /sources/koha/koha/C4/Search.pm,v
retrieving revision 1.126
retrieving revision 1.127
diff -u -b -r1.126 -r1.127
--- Search.pm 20 Oct 2006 01:20:56 -0000 1.126
+++ Search.pm 9 Mar 2007 14:31:47 -0000 1.127
@@ -1,6 +1,5 @@
package C4::Search;
-# Copyright 2000-2002 Katipo Communications
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
@@ -19,836 +18,425 @@
use strict;
require Exporter;
use C4::Context;
-use C4::Reserves2;
-use C4::Biblio;
-use ZOOM;
-use Encode;
-use C4::Date;
+use C4::Biblio; # MARCfind_marc_from_kohafield
+use C4::Koha; # getFacets
+use Lingua::Stem;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.126 $' =~ /\d+/g;
- shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+$VERSION = do { my @v = '$Revision: 1.127 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
-C4::Search - Functions for searching the Koha catalog and other databases
+C4::Search - Functions for searching the Koha catalog.
=head1 SYNOPSIS
- use C4::Search;
-
- my ($count, @results) = catalogsearch4($env, $type, $search, $num, $offset);
+see opac/opac-search.pl or catalogue/search.pl for example of usage
=head1 DESCRIPTION
-This module provides the searching facilities for the Koha catalog and
-ZEBRA databases.
-
-
+This module provides the searching facilities for the Koha into a zebra catalog.
=head1 FUNCTIONS
-=over 2
-
=cut
@ISA = qw(Exporter);
@EXPORT = qw(
- &barcodes &ItemInfo &itemcount
- &getcoverPhoto &add_query_line
- &FindDuplicate &ZEBRAsearch_kohafields &convertPQF &sqlsearch &cataloguing_search
-&getMARCnotes &getMARCsubjects &getMARCurls &getMARCadditional_authors &parsefields &spellSuggest);
-# make all your functions, whether exported or not;
-
-=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
-So you give an array of @kohafieldnames, at values, what relation they have @relations (equal, truncation etc) @and_or and
-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.
-This routine will also take CCL,CQL or PQF queries and pass them straight to the server
-See sub FindDuplicates for an example;
-=cut
-
-
-
+ &SimpleSearch
+ &findseealso
+ &FindDuplicate
+ &searchResults
+ &getRecords
+ &buildQuery
+);
-sub ZEBRAsearch_kohafields{
-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++){
- next if (@$value[$i] eq "");
- my $keyattr=MARCfind_attr_from_kohafield(@$kohafield[$i]) if (@$kohafield[$i]);
- if (!$keyattr){$keyattr=" \@attr 1=any";}
- @$value[$i]=~ s/(\.|\?|\;|\=|\/|\\|\||\:|\*|\!|\,|\(|\)|\[|\]|\{|\}|\/|\")/ /g;
- my $weighted=weightRank(@$kohafield[$i],@$value[$i],$i) unless($sort || $reorder);
- $query.=$weighted.@$relation[$i]." ".$keyattr." \"".@$value[$i]."\" " if @$value[$i];
- }
- for (my $z= 0;$z<=$#{$and_or};$z++){
- $query=@$and_or[$z]." ".$query if (@$value[$z+1] ne "");
- }
- }
+# make all your functions, whether exported or not;
-##warn $query;
-
-my @oConnection;
-($oConnection[0])=C4::Context->Zconn($server);
-my @sortpart;
-if ($reorder ){
- (@sortpart)=split /,/,$reorder;
-}elsif ($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," "; ##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
- }
-}
+=head2 findseealso($dbh,$fields);
-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;
-
-my $numresults;
-
-retry:
-$oResult= $oConnection[0]->search($query);
-my $i;
-my $event;
- while (($i = ZOOM::event(\@oConnection)) != 0) {
- $event = $oConnection[$i-1]->last_event();
- last if $event == ZOOM::Event::ZEND;
- }# while
-
- my($error, $errmsg, $addinfo, $diagset) = $oConnection[0]->error_x();
- if ($error==10007 && $tried<3) {## timeout --another 30 looonng seconds for this update
- $tried=$tried+1;
- goto "retry";
- }elsif ($error==2 && $tried<2) {## timeout --temporary zebra error !whatever that means
- $tried=$tried+1;
- goto "retry";
- }elsif ($error){
- warn "Error-$server /errcode:, $error, /MSG:,$errmsg,$addinfo \n";
- $oResult->destroy();
- $oConnection[0]->destroy();
- return (undef,undef);
- }
-my $dbh=C4::Context->dbh;
- $numresults=$oResult->size() ;
-
- if ($numresults>0){
- my $ri=0;
- my $z=0;
-
- $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 ($facets, at parsed)=parsefields($dbh,$searchfrom, at results);
- return ($numresults,$facets, at parsed) ;
- }
- }# if numresults
-
-$oResult->destroy();
-$oConnection[0]->destroy();
-EXITING:
-return ($numresults, at results) ;
-}
+C<$dbh> is a link to the DB handler.
-sub weightRank {
-my ($kohafield,$value,$i)=@_;
-### If a multi query is received weighting is reduced from 1st query being highest rank to last query being lowest;
-my $weighted;
-my $weight=1000 -($i*100);
-$weight=100 if $weight==0;
- return "" if $value eq "";
- my $keyattr=MARCfind_attr_from_kohafield($kohafield) if ($kohafield);
- return "" if($keyattr=~/4=109/ || $keyattr=~/4=4/ || $keyattr=~/4=5/); ###ranked sort not valid for numeric fields
- my $fullfield; ### not all indexes are Complete-field. Use only for title||author
- if ($kohafield eq "title" || $kohafield eq "" || $kohafield eq "any"){
- $keyattr=" \@attr 1=title-cover";
- $fullfield="\@attr 6=3 ";
- }elsif ($kohafield eq "author"){
- $fullfield="\@attr 6=3 ";
- }
- $weighted.="\@attr 2=102 ".$keyattr." \@attr 3=1 $fullfield \@attr 9=$weight \"".$value."\" " ;
- $weighted=" \@or ".$weighted;
- return $weighted;
-}
-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;
-}
+use C4::Context;
+my $dbh =C4::Context->dbh;
-return $pqf_query;
-}
+C<$fields> is a reference to the fields array
+This function modify the @$fields array and add related fields to search on.
-=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
=cut
-sub add_html_bold_fields {
- my ($type, $data, $search) = @_;
- foreach my $key ('title', 'author') {
- my $new_key;
-
- $new_key = 'bold_' . $key;
- $data->{$new_key} = $data->{$key};
- my $key1;
-
- $key1 = $key;
-
-
- my @keys;
- my $i = 1;
- if ($type eq 'keyword') {
- my $newkey=$search->{'keyword'};
- $newkey=~s /\++//g;
- @keys = split " ", $newkey;
- }
- my $count = @keys;
- for ($i = 0; $i < $count ; $i++) {
-
- if (($data->{$new_key} =~ /($keys[$i])/i) && (lc($keys[$i]) ne 'b') ) {
- my $word = $1;
- $data->{$new_key} =~ s/$word/<b>$word<\/b>/;
- }
+sub findseealso {
+ my ( $dbh, $fields ) = @_;
+ my $tagslib = MARCgettagslib( $dbh, 1 );
+ for ( my $i = 0 ; $i <= $#{$fields} ; $i++ ) {
+ my ($tag) = substr( @$fields[$i], 1, 3 );
+ my ($subfield) = substr( @$fields[$i], 4, 1 );
+ @$fields[$i] .= ',' . $tagslib->{$tag}->{$subfield}->{seealso}
+ if ( $tagslib->{$tag}->{$subfield}->{seealso} );
}
- }
-
-
-}
- sub sqlsearch{
-## This searches the SQL database only for biblionumber,itemnumber,barcode
-### Not very useful on production but as a debug tool useful during system maturing for ZEBRA operations
-
-my ($dbh,$search)=@_;
-my $sth;
-if ($search->{'barcode'} ne '') {
- $sth=$dbh->prepare("SELECT biblionumber from items where barcode=?");
- $sth->execute($search->{'barcode'});
-}elsif ($search->{'itemnumber'} ne '') {
- $sth=$dbh->prepare("SELECT biblionumber from items where itemnumber=?");
- $sth->execute($search->{'itemnumber'});
-}elsif ($search->{'biblionumber'} ne '') {
- $sth=$dbh->prepare("SELECT biblionumber from biblio where biblionumber=?");
- $sth->execute($search->{'biblionumber'});
-}else{
-return (undef,undef);
}
- my $result=$sth->fetchrow_hashref;
-return (1,$result) if $result;
-}
-
-sub cataloguing_search{
-## This is an SQL based search designed to be used when adding a new biblio incase library sets
-## preference zebraorsql to sql when adding a new biblio
-my ($search,$num,$offset) = @_;
- my ($count, at results);
-my $dbh=C4::Context->dbh;
-#Prepare search
-my $query;
-my $condition="select SQL_CALC_FOUND_ROWS marcxml from biblio where ";
-if ($search->{'isbn'} ne''){
-$search->{'isbn'}=$search->{'isbn'}."%";
-$query=$search->{'isbn'};
-$condition.= " isbn like ? ";
-}else{
-return (0,undef) unless $search->{title};
-$query=$search->{'title'};
-$condition.= " MATCH (title) AGAINST(? in BOOLEAN MODE ) ";
-}
-my $sth=$dbh->prepare($condition);
-$sth->execute($query);
- my $nbresult=$dbh->prepare("SELECT FOUND_ROWS()");
- $nbresult->execute;
- my $count=$nbresult->fetchrow;
-my $limit = $num + $offset;
-my $startfrom = $offset;
-my $i=0;
-my @results;
-while (my $marc=$sth->fetchrow){
- if (($i >= $startfrom) && ($i < $limit)) {
- my $record=XML_xml2hash_onerecord($marc);
- my $data=XMLmarc2koha_onerecord($dbh,$record,"biblios");
- push @results,$data;
- }
-$i++;
-last if $i==$limit;
-}
-return ($count, at results);
-}
+=head2 FindDuplicate
+($biblionumber,$biblionumber,$title) = FindDuplicate($record);
+=cut
sub FindDuplicate {
- my ($xml)=@_;
-my $dbh=C4::Context->dbh;
- my ($result) = XMLmarc2koha_onerecord($dbh,$xml,"biblios");
- my @kohafield;
- my @value;
- my @relation;
- my @and_or;
-
- # search duplicate on ISBN, easy and fast..
-
- if ($result->{isbn}) {
- push @kohafield,"isbn";
-###Temporary fix for ISBN
-my $isbn=$result->{isbn};
-$isbn=~ s/(\.|\?|\;|\=|\/|\\|\||\:|\!|\'|,|\-|\"|\*|\(|\)|\[|\]|\{|\}|\/)//g;
- push @value,$isbn;
- }else{
-$result->{title}=~s /\\//g;
-$result->{title}=~s /\"//g;
-$result->{title}=~ s/(\.|\?|\;|\=|\/|\\|\||\:|\*|\!|\,|\-|\(|\)|\[|\]|\{|\}|\/)/ /g;
-
- push @kohafield,"title";
- push @value,$result->{title};
- push @relation,"\@attr 6=3 \@attr 4=1 \@attr 5=1"; ## right truncated,phrase,whole field
-
- }
- my ($total, at result)=ZEBRAsearch_kohafields(\@kohafield,\@value,\@relation,"",\@and_or,0,"",0,1);
-if ($total){
-my $title=XML_readline($result[0],"title","biblios") ;
-my $biblionumber=XML_readline($result[0],"biblionumber","biblios") ;
- return $biblionumber,$title ;
-}
-
-}
-
-
-sub add_query_line {
-
- my ($type,$search,$results)=@_;
+ my ($record) = @_;
+ return;
my $dbh = C4::Context->dbh;
- my $searchdesc = '';
- my $from;
- my $borrowernumber = $search->{'borrowernumber'};
- my $remote_IP = $search->{'remote_IP'};
- my $remote_URL= $search->{'remote_URL'};
- my $searchdesc = $search->{'searchdesc'};
-
-my $sth = $dbh->prepare("INSERT INTO phrase_log(phr_phrase,phr_resultcount,phr_ip,user,actual) VALUES(?,?,?,?,?)");
-
-
-$sth->execute($searchdesc,$results,$remote_IP,$borrowernumber,$remote_URL);
-$sth->finish;
-
-}
-
-
-=item ItemInfo
-
- @results = &ItemInfo($env, $biblionumber, $type);
-
-Returns information about books with the given biblionumber.
-
-C<$type> may be either C<intra> or anything else. If it is not set to
-C<intra>, then the search will exclude lost, very overdue, and
-withdrawn items.
-
-C<$env> is ignored.
-
-C<&ItemInfo> returns a list of references-to-hash. Each element
-contains a number of keys. Most of them are table items from the
-C<biblio>, C<biblioitems>, C<items>, and C<itemtypes> tables in the
-Koha database. Other keys include:
-
-=over 4
-
-=item C<$data-E<gt>{branchname}>
-
-The name (not the code) of the branch to which the book belongs.
-
-=item C<$data-E<gt>{datelastseen}>
+ my $result = MARCmarc2koha( $dbh, $record, '' );
+ my $sth;
+ my $query;
+ my $search;
+ my $type;
+ my ( $biblionumber, $title );
-This is simply C<items.datelastseen>, except that while the date is
-stored in YYYY-MM-DD format in the database, here it is converted to
-DD/MM/YYYY format. A NULL date is returned as C<//>.
-
-=item C<$data-E<gt>{datedue}>
-
-=item C<$data-E<gt>{class}>
-
-This is the concatenation of C<biblioitems.classification>, the book's
-Dewey code, and C<biblioitems.subclass>.
-
-=item C<$data-E<gt>{ocount}>
-
-I think this is the number of copies of the book available.
-
-=item C<$data-E<gt>{order}>
-
-If this is set, it is set to C<One Order>.
-
-=back
-
-=cut
-#'
-sub ItemInfo {
- my ($dbh,$data) = @_;
- my $i=0;
- my @results;
-my ($date_due, $count_reserves);
- my $datedue = '';
- my $isth=$dbh->prepare("Select issues.*,borrowers.cardnumber from issues,borrowers where itemnumber = ? and returndate is null and issues.borrowernumber=borrowers.borrowernumber");
- $isth->execute($data->{'itemnumber'});
- if (my $idata=$isth->fetchrow_hashref){
- $data->{borrowernumber} = $idata->{borrowernumber};
- $data->{cardnumber} = $idata->{cardnumber};
- $datedue = format_date($idata->{'date_due'});
- }
- if ($datedue eq '' || $datedue eq "0000-00-00"){
- $datedue="";
- my ($restype,$reserves)=C4::Reserves2::CheckReserves($data->{'itemnumber'});
- if ($restype) {
- $count_reserves = $restype;
- }
+ # search duplicate on ISBN, easy and fast..
+ #$search->{'avoidquerylog'}=1;
+ if ( $result->{isbn} ) {
+ $query = "isbn=$result->{isbn}";
}
- $isth->finish;
- #get branch information.....
- my $bsth=$dbh->prepare("SELECT * FROM branches WHERE branchcode = ?");
- $bsth->execute($data->{'holdingbranch'});
- if (my $bdata=$bsth->fetchrow_hashref){
- $data->{'branchname'} = $bdata->{'branchname'};
+ else {
+ $result->{title} =~ s /\\//g;
+ $result->{title} =~ s /\"//g;
+ $result->{title} =~ s /\(//g;
+ $result->{title} =~ s /\)//g;
+ $query = "ti,ext=$result->{title}";
}
+ my ($possible_duplicate_record) =
+ C4::Biblio::getRecord( "biblioserver", $query, "usmarc" ); # FIXME :: hardcoded !
+ if ($possible_duplicate_record) {
+ my $marcrecord =
+ MARC::Record->new_from_usmarc($possible_duplicate_record);
+ my $result = MARCmarc2koha( $dbh, $marcrecord, '' );
- $data->{'datelastseen'}=format_date($data->{'datelastseen'});
- $data->{'datedue'}=$datedue;
- $data->{'count_reserves'} = $count_reserves;
- # get notforloan complete status if applicable
- my ($tagfield,$tagsub)=MARCfind_marc_from_kohafield("notforloan","holdings");
- my $sthnflstatus = $dbh->prepare("select authorised_value from holdings_subfield_structure where tagfield='$tagfield' and tagsubfield='$tagsub'");
- $sthnflstatus->execute;
- my ($authorised_valuecode) = $sthnflstatus->fetchrow;
- if ($authorised_valuecode) {
- $sthnflstatus = $dbh->prepare("select lib from authorised_values where category=? and authorised_value=?");
- $sthnflstatus->execute($authorised_valuecode,$data->{itemnotforloan});
- my ($lib) = $sthnflstatus->fetchrow;
- $data->{notforloan} = $lib;
+ # FIXME :: why 2 $biblionumber ?
+ return $result->{'biblionumber'}, $result->{'biblionumber'},
+ $result->{'title'}
+ if $result;
}
-
-# my shelf procedures
- my ($tagfield,$tagsubfield)=MARCfind_marc_from_kohafield("shelf","holdings");
-
- my $shelfstatus = $dbh->prepare("select authorised_value from holdings_subfield_structure where tagfield='$tagfield' and tagsubfield='$tagsubfield'");
-$shelfstatus->execute;
- $authorised_valuecode = $shelfstatus->fetchrow;
- if ($authorised_valuecode) {
- $shelfstatus = $dbh->prepare("select lib from authorised_values where category=? and authorised_value=?");
- $shelfstatus->execute($authorised_valuecode,$data->{shelf});
-
- my ($lib) = $shelfstatus->fetchrow;
- $data->{shelf} = $lib;
- }
-
-
-
- return($data);
}
+=head2 SimpleSearch
+($error,$results) = SimpleSearch($query, at servers);
+this function performs a simple search on the catalog using zoom.
+=over 2
-=item barcodes
+=item C<input arg:>
- @barcodes = &barcodes($biblioitemnumber);
+ * $query could be a simple keyword or a complete CCL query wich is depending on your ccl file.
+ * @servers is optionnal. default one is read on koha.xml
-Given a biblioitemnumber, looks up the corresponding items.
+=item C<Output arg:>
+ * $error is a string which containt the description error if there is one. Else it's empty.
+ * \@results is an array of marc record.
-Returns an array of references-to-hash; the keys are C<barcode> and
-C<itemlost>.
+=item C<usage in the script:>
-The returned items include very overdue items, but not lost ones.
+=back
-=cut
-#'
-sub barcodes{
- #called from request.pl
- my ($biblionumber)=@_;
-#warn $biblionumber;
- my $dbh = C4::Context->dbh;
- my @kohafields;
- my @values;
- my @relations;
- my $sort;
- my @and_or;
- my @fields;
- push @kohafields, "biblionumber";
- push @values,$biblionumber;
- push @relations, " "," \@attr 2=1"; ## selecting wthdrawn less then 1
- push @and_or, "\@and";
- $sort="";
- my ($count, at results)=ZEBRAsearch_kohafields(\@kohafields,\@values,\@relations,$sort,\@and_or,"","");
-push @fields,"barcode","itemlost","itemnumber","date_due","wthdrawn","notforloan";
- my ($biblio, at items)=XMLmarc2koha($dbh,$results[0],"holdings", @fields);
-return(@items);
-}
+my ($error, $marcresults) = SimpleSearch($query);
+if (defined $error) {
+ $template->param(query_error => $error);
+ warn "error: ".$error;
+ output_html_with_http_headers $input, $cookie, $template->output;
+ exit;
+}
+my $hits = scalar @$marcresults;
+my @results;
+for(my $i=0;$i<$hits;$i++) {
+ my %resultsloop;
+ my $marcrecord = MARC::File::USMARC::decode($marcresults->[$i]);
+ my $biblio = MARCmarc2koha(C4::Context->dbh,$marcrecord,'');
+
+ #build the hash for the template.
+ $resultsloop{highlight} = ($i % 2)?(1):(0);
+ $resultsloop{title} = $biblio->{'title'};
+ $resultsloop{subtitle} = $biblio->{'subtitle'};
+ $resultsloop{biblionumber} = $biblio->{'biblionumber'};
+ $resultsloop{author} = $biblio->{'author'};
+ $resultsloop{publishercode} = $biblio->{'publishercode'};
+ $resultsloop{publicationyear} = $biblio->{'publicationyear'};
+ push @results, \%resultsloop;
+}
+$template->param(result=>\@results);
-sub getMARCnotes {
-##Requires a MARCXML as $record
- my ($dbh, $record, $marcflavour) = @_;
+=cut
- my ($mintag, $maxtag);
- if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
- $mintag = "500";
- $maxtag = "599";
- } else { # assume unimarc if not marc21
- $mintag = "300";
- $maxtag = "399";
+sub SimpleSearch {
+ my $query = shift;
+ my @servers = @_;
+ my @results;
+ my @tmpresults;
+ my @zconns;
+ return ( "No query entered", undef ) unless $query;
+
+ #@servers = (C4::Context->config("biblioserver")) unless @servers;
+ @servers =
+ ("biblioserver") unless @servers
+ ; # FIXME hardcoded value. See catalog/search.pl & opac-search.pl too.
+
+ # Connect & Search
+ for ( my $i = 0 ; $i < @servers ; $i++ ) {
+ $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
+ $tmpresults[$i] =
+ $zconns[$i]
+ ->search( new ZOOM::Query::CCL2RPN( $query, $zconns[$i] ) );
+
+ # getting error message if one occured.
+ my $error =
+ $zconns[$i]->errmsg() . " ("
+ . $zconns[$i]->errcode() . ") "
+ . $zconns[$i]->addinfo() . " "
+ . $zconns[$i]->diagset();
+
+ return ( $error, undef ) if $zconns[$i]->errcode();
+ }
+ my $hits;
+ my $ev;
+ while ( ( my $i = ZOOM::event( \@zconns ) ) != 0 ) {
+ $ev = $zconns[ $i - 1 ]->last_event();
+ if ( $ev == ZOOM::Event::ZEND ) {
+ $hits = $tmpresults[ $i - 1 ]->size();
+ }
+ if ( $hits > 0 ) {
+ for ( my $j = 0 ; $j < $hits ; $j++ ) {
+ my $record = $tmpresults[ $i - 1 ]->record($j)->raw();
+ push @results, $record;
}
- my @marcnotes=();
-
- foreach my $field ($mintag..$maxtag) {
- my %line;
- my @values=XML_readline_asarray($record,"","",$field,"");
- foreach my $value (@values){
- $line{MARCNOTE}=$value if $value;
- push @marcnotes,\%line if $line{MARCNOTE};
}
}
+ return ( undef, \@results );
+}
+
+# performs the search
+sub getRecords {
+ my (
+ $koha_query, $federated_query, $sort_by_ref,
+ $servers_ref, $results_per_page, $offset,
+ $expanded_facet, $branches, $query_type,
+ $scan
+ ) = @_;
+
+ my @servers = @$servers_ref;
+ my @sort_by = @$sort_by_ref;
+
+ # create the zoom connection and query object
+ my $zconn;
+ my @zconns;
+ my @results;
+ my $results_hashref = ();
- my $marcnotesarray=\@marcnotes;
- return $marcnotesarray;
-
-} # end getMARCnotes
-
-
-sub getMARCsubjects {
-
- my ($dbh, $record, $marcflavour) = @_;
- my ($mintag, $maxtag);
- if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
- $mintag = "600";
- $maxtag = "699";
- } else { # assume unimarc if not marc21
- $mintag = "600";
- $maxtag = "619";
- }
- my @marcsubjcts;
- my $subjct = "";
- my $subfield = "";
- my $marcsubjct;
+ ### FACETED RESULTS
+ my $facets_counter = ();
+ my $facets_info = ();
+ my $facets = getFacets();
- foreach my $field ($mintag..$maxtag) {
- my @value =XML_readline_asarray($record,"","",$field,"a");
- foreach my $subject (@value){
- $marcsubjct = {MARCSUBJCT => $subject,};
- push @marcsubjcts, $marcsubjct;
- }
+ #### INITIALIZE SOME VARS USED CREATE THE FACETED RESULTS
+ my @facets_loop; # stores the ref to array of hashes for template
+ for ( my $i = 0 ; $i < @servers ; $i++ ) {
+ $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
+# perform the search, create the results objects
+# if this is a local search, use the $koha-query, if it's a federated one, use the federated-query
+ my $query_to_use;
+ if ( $servers[$i] =~ /biblioserver/ ) {
+ $query_to_use = $koha_query;
+ }
+ else {
+ $query_to_use = $federated_query;
+ }
+
+ # warn "HERE : $query_type => $query_to_use";
+ # check if we've got a query_type defined
+ eval {
+ if ($query_type)
+ {
+ if ( $query_type =~ /^ccl/ ) {
+ $query_to_use =~
+ s/\:/\=/g; # change : to = last minute (FIXME)
+
+ # warn "CCL : $query_to_use";
+ $results[$i] =
+ $zconns[$i]->search(
+ new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
+ );
}
- my $marcsubjctsarray=\@marcsubjcts;
- return $marcsubjctsarray;
-} #end getMARCsubjects
-
+ elsif ( $query_type =~ /^cql/ ) {
-sub getMARCurls {
- my ($dbh, $record, $marcflavour) = @_;
- my ($mintag, $maxtag);
- if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
- $mintag = "856";
- $maxtag = "856";
- } else { # assume unimarc if not marc21
- $mintag = "600";
- $maxtag = "619";
+ # warn "CQL : $query_to_use";
+ $results[$i] =
+ $zconns[$i]->search(
+ new ZOOM::Query::CQL( $query_to_use, $zconns[$i] ) );
}
+ elsif ( $query_type =~ /^pqf/ ) {
- my @marcurls;
- my $url = "";
- my $subfil = "";
- my $marcurl;
- my $value;
- foreach my $field ($mintag..$maxtag) {
- my @value =XML_readline_asarray($record,"","",$field,"u");
- foreach my $url (@value){
- if ( $value ne $url) {
- $marcurl = {MARCURL => $url,};
- push @marcurls, $marcurl;
- $value=$url;
+ # warn "PQF : $query_to_use";
+ $results[$i] =
+ $zconns[$i]->search(
+ new ZOOM::Query::PQF( $query_to_use, $zconns[$i] ) );
}
}
- }
-
-
- my $marcurlsarray=\@marcurls;
- return $marcurlsarray;
-} #end getMARCurls
+ else {
+ if ($scan) {
-sub getMARCadditional_authors {
- my ($dbh, $record, $marcflavour) = @_;
- my ($mintag, $maxtag);
- if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
- $mintag = "700";
- $maxtag = "700";
- } else { # assume unimarc if not marc21
-###FIX ME Correct tag to UNIMARC additional authors
- $mintag = "200";
- $maxtag = "200";
+ # warn "preparing to scan";
+ $results[$i] =
+ $zconns[$i]->scan(
+ new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
+ );
}
+ else {
- my @marcauthors;
-
- my $subfil = "";
- my $marcauth;
- my $value;
- foreach my $field ($mintag..$maxtag) {
- my @value =XML_readline_asarray($record,"","",$field,"a");
- foreach my $author (@value){
- if ( $value ne $author) {
- $marcauth = {MARCAUTHOR => $author,};
- push @marcauthors, $marcauth;
- $value=$author;
+ # warn "LAST : $query_to_use";
+ $results[$i] =
+ $zconns[$i]->search(
+ new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
+ );
}
}
+ };
+ if ($@) {
+ warn "prob with query toto $query_to_use " . $@;
+ }
+
+ # concatenate the sort_by limits and pass them to the results object
+ my $sort_by;
+ foreach my $sort (@sort_by) {
+ $sort_by .= $sort . " "; # used to be $sort,
+ }
+ $results[$i]->sort( "yaz", $sort_by ) if $sort_by;
+ }
+ while ( ( my $i = ZOOM::event( \@zconns ) ) != 0 ) {
+ my $ev = $zconns[ $i - 1 ]->last_event();
+ if ( $ev == ZOOM::Event::ZEND ) {
+ my $size = $results[ $i - 1 ]->size();
+ if ( $size > 0 ) {
+ my $results_hash;
+ #$results_hash->{'server'} = $servers[$i-1];
+ # loop through the results
+ $results_hash->{'hits'} = $size;
+ my $times;
+ if ( $offset + $results_per_page <= $size ) {
+ $times = $offset + $results_per_page;
+ }
+ else {
+ $times = $size;
+ }
+ for ( my $j = $offset ; $j < $times ; $j++ )
+ { #(($offset+$count<=$size) ? ($offset+$count):$size) ; $j++){
+ my $records_hash;
+ my $record;
+ my $facet_record;
+ ## This is just an index scan
+ if ($scan) {
+ my ( $term, $occ ) = $results[ $i - 1 ]->term($j);
+
+ # here we create a minimal MARC record and hand it off to the
+ # template just like a normal result ... perhaps not ideal, but
+ # it works for now
+ my $tmprecord = MARC::Record->new();
+ $tmprecord->encoding('UTF-8');
+ my $tmptitle;
+
+ # srote the minimal record in author/title (depending on MARC flavour)
+ if ( C4::Context->preference("marcflavour") eq
+ "UNIMARC" )
+ {
+ $tmptitle = MARC::Field->new(
+ '200', ' ', ' ',
+ a => $term,
+ f => $occ
+ );
}
-
-
- my $marcauthsarray=\@marcauthors;
- return $marcauthsarray;
-} #end getMARCurls
-
-sub parsefields{
-#pass this a MARC record and it will parse it for display purposes
-my ($dbh,$intranet, at marcrecords)=@_;
-my @results;
-my @items;
-my $retrieve_from=C4::Context->preference('retrieve_from');
-#Build brancnames hash for displaying in OPAC - more user friendly
-#find branchname
-#get branch information.....
-my %branches;
- my $bsth=$dbh->prepare("SELECT branchcode,branchname FROM branches");
- $bsth->execute();
- while (my $bdata=$bsth->fetchrow_hashref){
- $branches{$bdata->{'branchcode'}}= $bdata->{'branchname'};
+ else {
+ $tmptitle = MARC::Field->new(
+ '245', ' ', ' ',
+ a => $term,
+ b => $occ
+ );
}
-
-#Building shelving hash if library has shelves defined like junior section, non-fiction, audio-visual room etc
-my %shelves;
-#find shelvingname
-my ($tagfield,$tagsubfield)=MARCfind_marc_from_kohafield("shelf","holdings");
-my $shelfstatus = $dbh->prepare("select authorised_value from holdings_subfield_structure where tagfield='$tagfield' and tagsubfield='$tagsubfield'");
- $shelfstatus->execute;
- my ($authorised_valuecode) = $shelfstatus->fetchrow;
- if ($authorised_valuecode) {
- $shelfstatus = $dbh->prepare("select lib,authorised_value from authorised_values where category=? ");
- $shelfstatus->execute($authorised_valuecode);
- while (my $lib = $shelfstatus->fetchrow_hashref){
- $shelves{$lib->{'authorised_value'}} = $lib->{'lib'};
+ $tmprecord->append_fields($tmptitle);
+ $results_hash->{'RECORDS'}[$j] =
+ $tmprecord->as_usmarc();
+ }
+ else {
+ $record = $results[ $i - 1 ]->record($j)->raw();
+
+ #warn "RECORD $j:".$record;
+ $results_hash->{'RECORDS'}[$j] =
+ $record; # making a reference to a hash
+ # Fill the facets while we're looping
+ $facet_record = MARC::Record->new_from_usmarc($record);
+
+ #warn $servers[$i-1].$facet_record->title();
+ for ( my $k = 0 ; $k <= @$facets ; $k++ ) {
+ if ( $facets->[$k] ) {
+ my @fields;
+ for my $tag ( @{ $facets->[$k]->{'tags'} } ) {
+ push @fields, $facet_record->field($tag);
}
+ for my $field (@fields) {
+ my @subfields = $field->subfields();
+ for my $subfield (@subfields) {
+ my ( $code, $data ) = @$subfield;
+ if ( $code eq
+ $facets->[$k]->{'subfield'} )
+ {
+ $facets_counter->{ $facets->[$k]
+ ->{'link_value'} }->{$data}++;
}
-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){
-
- 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","subclass","itemtype","copyrightdate", "holdingbranch","date_due","location","shelf","itemcallnumber","notforloan","itemlost","wthdrawn";
-my ($oldbiblio, at itemrecords) = XMLmarc2koha($dbh,$xml,"", at kohafields);
-my $bibliorecord;
-
-my %counts;
-
-$counts{'total'}=0;
-my $noitems = 1;
-my $norequests = 1;
- ##Loop for each item field
-
- foreach my $item (@itemrecords) {
- $norequests = 0 unless $item->{'itemnotforloan'};
- $noitems = 0;
- my $status;
- #renaming some fields according to templates
- $item->{'branchname'}=$branches{$item->{'holdingbranch'}};
- $item->{'shelves'}=$shelves{$item->{'shelf'}};
- $status="Lost" if ($item->{'itemlost'}>0);
- $status="Withdrawn" if ($item->{'wthdrawn'}>0);
- if ($intranet eq "intranet"){ ## we give full itemcallnumber detail in intranet
- $status="Due:".format_date($item->{'date_due'}) if ($item->{'date_due'} gt "0000-00-00");
- $status = $item->{'holdingbranch'}."-".$item->{'shelf'}."[".$item->{'itemcallnumber'}."]" unless defined $status;
- }else{
- $status="On Loan" if ($item->{'date_due'} gt "0000-00-00");
- $status = $item->{'branchname'}."[".$item->{'shelves'}."]" unless defined $status;
- }
-
- $counts{$status}++;
- $counts{'total'}++;
- }
- $oldbiblio->{'noitems'} = $noitems;
- $oldbiblio->{'norequests'} = $norequests;
- $oldbiblio->{'even'} = $even;
- $even= not $even;
- if ($even){
- $oldbiblio->{'toggle'}="#ffffcc";
- } else {
- $oldbiblio->{'toggle'}="white";
- } ; ## some forms seems to use toggle
-
- $oldbiblio->{'itemcount'} = $counts{'total'};
- my $totalitemcounts = 0;
- foreach my $key (keys %counts){
- if ($key ne 'total'){
- $totalitemcounts+= $counts{$key};
- $oldbiblio->{'locationhash'}->{$key}=$counts{$key};
-
- }
- }
- my ($locationtext, $locationtextonly, $notavailabletext) = ('','','');
- foreach (sort keys %{$oldbiblio->{'locationhash'}}) {
-
- if ($_ eq 'notavailable') {
- $notavailabletext="Not available";
- my $c=$oldbiblio->{'locationhash'}->{$_};
- $oldbiblio->{'not-available-p'}=$c;
- } else {
- $locationtext.="$_";
- my $c=$oldbiblio->{'locationhash'}->{$_};
- if ($_ eq 'Lost') {
- $oldbiblio->{'lost-p'} = $c;
- } elsif ($_ eq 'Withdrawn') {
- $oldbiblio->{'withdrawn-p'} = $c;
- } elsif ($_ =~/\^Due:/) {
-
- $oldbiblio->{'on-loan-p'} = $c;
- } else {
- $locationtextonly.= $_;
- $locationtextonly.= " ($c)<br> " if $totalitemcounts > 1;
- }
- if ($totalitemcounts>1) {
- $locationtext.=" ($c)<br> ";
- }
- }
- }
- if ($notavailabletext) {
- $locationtext.= $notavailabletext;
- } else {
- $locationtext=~s/, $//;
- }
- $oldbiblio->{'location'} = $locationtext;
- $oldbiblio->{'location-only'} = $locationtextonly;
- $oldbiblio->{'use-location-flags-p'} = 1;
- push @results,$oldbiblio;
-
-}## For each record received
- at facets_loop=BuildFacets($facets_counter,$facets_info,%branches);
-
- return(@facets_loop, at 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){
- for (my $z=0; $z<@$subfields;$z++) {
- my $data=XML_readline_onerecord($holding,"","holdings",@$tags[$i],@$subfields[$z]);
- $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'};
}
- }else{
- for (my $z=0; $z<@$subfields;$z++) {
- my $data=XML_readline($facet_record,"","biblios",@$tags[$i],@$subfields[$z]);
- $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'};
+ $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
}
-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) {
+ #print "connection ", $i-1, ": $size hits";
+ #print $results[$i-1]->record(0)->render() if $size > 0;
+ # BUILD FACETS
+ for 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}} ) {
+ for 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'})) {
+ if ( ( $number_of_facets < 6 )
+ || ( $expanded_facet eq $link_value )
+ || ( $facets_info->{$link_value}->{'expanded'} ) )
+ {
# sanitize the link value ), ( will cause errors with CCL
my $facet_link_value = $one_facet;
@@ -856,215 +444,606 @@
# 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;
+ $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};
+ if ( $link_value =~ /branch/ ) {
+ $facet_label_value =
+ $branches->{$one_facet}->{'branchname'};
}
# 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 },
+ 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' },
+ }
+ }
+ unless ( $facets_info->{$link_value}->{'expanded'} ) {
+ $expandable = 1
+ if ( ( $number_of_facets > 6 )
+ && ( $expanded_facet ne $link_value ) );
+ }
+ 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 ;
-
- my $image=XML_readline_onerecord($record,"coverphoto","biblios");
- if ($image){
- return $image;
}
-# if there is no image put the amazon cover image adress
-
-my $isbn=XML_readline_onerecord($record,"isbn","biblios");
-return "http://images.amazon.com/images/P/".$isbn.".01.MZZZZZZZ.jpg";
+ }
+ return ( undef, $results_hashref, \@facets_loop );
}
-=item itemcount
-
- ($count, $lcount, $nacount, $fcount, $scount, $lostcount,
- $mending, $transit,$ocount) =
- &itemcount($env, $biblionumber, $type);
-
-Counts the number of items with the given biblionumber, broken down by
-category.
-
-C<$env> is ignored.
-
-If C<$type> is not set to C<intra>, lost, very overdue, and withdrawn
-items will not be counted.
-
-C<&itemcount> returns a nine-element list:
-
-C<$count> is the total number of items with the given biblionumber.
-
-C<$lcount> is the number of items at the Levin branch.
-
-C<$nacount> is the number of items that are neither borrowed, lost,
-nor withdrawn (and are therefore presumably on a shelf somewhere).
-
-C<$fcount> is the number of items at the Foxton branch.
-
-C<$scount> is the number of items at the Shannon branch.
-
-C<$lostcount> is the number of lost and very overdue items.
+# build the query itself
+sub buildQuery {
+ my ( $query, $operators, $operands, $indexes, $limits, $sort_by ) = @_;
+
+ my @operators = @$operators if $operators;
+ my @indexes = @$indexes if $indexes;
+ my @operands = @$operands if $operands;
+ my @limits = @$limits if $limits;
+ my @sort_by = @$sort_by if $sort_by;
+
+ my $human_search_desc; # a human-readable query
+ my $machine_search_desc; #a machine-readable query
+ # FIXME: the locale should be set based on the syspref
+ my $stemmer = Lingua::Stem->new( -locale => 'EN-US' );
+
+# FIXME: these should be stored in the db so the librarian can modify the behavior
+ $stemmer->add_exceptions(
+ {
+ 'and' => 'and',
+ 'or' => 'or',
+ 'not' => 'not',
+ }
+ );
-C<$mending> is the number of items at the Mending branch (being
-mended?).
+# STEP I: determine if this is a form-based / simple query or if it's complex (if complex,
+# we can't handle field weighting, stemming until a formal query parser is written
+# I'll work on this soon -- JF
+#if (!$query) { # form-based
+# check if this is a known query language query, if it is, return immediately:
+ if ( $query =~ /^ccl=/ ) {
+ return ( undef, $', $', $', 'ccl' );
+ }
+ if ( $query =~ /^cql=/ ) {
+ return ( undef, $', $', $', 'cql' );
+ }
+ if ( $query =~ /^pqf=/ ) {
+ return ( undef, $', $', $', 'pqf' );
+ }
+ if ( $query =~ /(\(|\))/ ) { # sorry, too complex
+ return ( undef, $query, $query, $query, 'ccl' );
+ }
+
+# form-based queries are limited to non-nested a specific depth, so we can easily
+# modify the incoming query operands and indexes to do stemming and field weighting
+# Once we do so, we'll end up with a value in $query, just like if we had an
+# incoming $query from the user
+ else {
+ $query = ""
+ ; # clear it out so we can populate properly with field-weighted stemmed query
+ my $previous_operand
+ ; # a flag used to keep track if there was a previous query
+ # if there was, we can apply the current operator
+ for ( my $i = 0 ; $i <= @operands ; $i++ ) {
+ my $operand = $operands[$i];
+ my $index = $indexes[$i];
+ my $stemmed_operand;
+ my $stemming = C4::Context->parameters("Stemming") || 0;
+ my $weight_fields = C4::Context->parameters("WeightFields") || 0;
+
+ if ( $operands[$i] ) {
+
+# STEMMING FIXME: need to refine the field weighting so stemmed operands don't disrupt the query ranking
+ if ($stemming) {
+ my @words = split( / /, $operands[$i] );
+ my $stems = $stemmer->stem(@words);
+ foreach my $stem (@$stems) {
+ $stemmed_operand .= "$stem";
+ $stemmed_operand .= "?"
+ unless ( $stem =~ /(and$|or$|not$)/ )
+ || ( length($stem) < 3 );
+ $stemmed_operand .= " ";
+
+ #warn "STEM: $stemmed_operand";
+ }
+
+ #$operand = $stemmed_operand;
+ }
+
+# FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
+# pretty well but will work much better when we have an actual query parser
+ my $weighted_query;
+ if ($weight_fields) {
+ $weighted_query .=
+ " rk=("; # Specifies that we're applying rank
+ # keyword has different weight properties
+ if ( ( $index =~ /kw/ ) || ( !$index ) )
+ { # FIXME: do I need to add right-truncation in the case of stemming?
+ # a simple way to find out if this query uses an index
+ if ( $operand =~ /(\=|\:)/ ) {
+ $weighted_query .= " $operand";
+ }
+ else {
+ $weighted_query .=
+ " Title-cover,ext,r1=\"$operand\""
+ ; # index label as exact
+ $weighted_query .=
+ " or ti,ext,r2=$operand"; # index as exact
+ #$weighted_query .= " or ti,phr,r3=$operand"; # index as phrase
+ #$weighted_query .= " or any,ext,r4=$operand"; # index as exact
+ $weighted_query .=
+ " or kw,wrdl,r5=$operand"; # index as exact
+ $weighted_query .= " or wrd,fuzzy,r9=$operand";
+ $weighted_query .= " or wrd=$stemmed_operand"
+ if $stemming;
+ }
+ }
+ elsif ( $index =~ /au/ ) {
+ $weighted_query .=
+ " $index,ext,r1=$operand"; # index label as exact
+ #$weighted_query .= " or (title-sort-az=0 or $index,startswithnt,st-word,r3=$operand #)";
+ $weighted_query .=
+ " or $index,phr,r3=$operand"; # index as phrase
+ $weighted_query .= " or $index,rt,wrd,r3=$operand";
+ }
+ elsif ( $index =~ /ti/ ) {
+ $weighted_query .=
+ " Title-cover,ext,r1=$operand"; # index label as exact
+ $weighted_query .= " or Title-series,ext,r2=$operand";
+
+ #$weighted_query .= " or ti,ext,r2=$operand";
+ #$weighted_query .= " or ti,phr,r3=$operand";
+ #$weighted_query .= " or ti,wrd,r3=$operand";
+ $weighted_query .=
+" or (title-sort-az=0 or Title-cover,startswithnt,st-word,r3=$operand #)";
+ $weighted_query .=
+" or (title-sort-az=0 or Title-cover,phr,r6=$operand)";
+
+ #$weighted_query .= " or Title-cover,wrd,r5=$operand";
+ #$weighted_query .= " or ti,ext,r6=$operand";
+ #$weighted_query .= " or ti,startswith,phr,r7=$operand";
+ #$weighted_query .= " or ti,phr,r8=$operand";
+ #$weighted_query .= " or ti,wrd,r9=$operand";
+
+ #$weighted_query .= " or ti,ext,r2=$operand"; # index as exact
+ #$weighted_query .= " or ti,phr,r3=$operand"; # index as phrase
+ #$weighted_query .= " or any,ext,r4=$operand"; # index as exact
+ #$weighted_query .= " or kw,wrd,r5=$operand"; # index as exact
+ }
+ else {
+ $weighted_query .=
+ " $index,ext,r1=$operand"; # index label as exact
+ #$weighted_query .= " or $index,ext,r2=$operand"; # index as exact
+ $weighted_query .=
+ " or $index,phr,r3=$operand"; # index as phrase
+ $weighted_query .= " or $index,rt,wrd,r3=$operand";
+ $weighted_query .=
+ " or $index,wrd,r5=$operand"
+ ; # index as word right-truncated
+ $weighted_query .= " or $index,wrd,fuzzy,r8=$operand";
+ }
+ $weighted_query .= ")"; # close rank specification
+ $operand = $weighted_query;
+ }
+
+ # only add an operator if there is a previous operand
+ if ($previous_operand) {
+ if ( $operators[ $i - 1 ] ) {
+ $query .= " $operators[$i-1] $index: $operand";
+ if ( !$index ) {
+ $human_search_desc .=
+ " $operators[$i-1] $operands[$i]";
+ }
+ else {
+ $human_search_desc .=
+ " $operators[$i-1] $index: $operands[$i]";
+ }
+ }
+
+ # the default operator is and
+ else {
+ $query .= " and $index: $operand";
+ $human_search_desc .= " and $index: $operands[$i]";
+ }
+ }
+ else {
+ if ( !$index ) {
+ $query .= " $operand";
+ $human_search_desc .= " $operands[$i]";
+ }
+ else {
+ $query .= " $index: $operand";
+ $human_search_desc .= " $index: $operands[$i]";
+ }
+ $previous_operand = 1;
+ }
+ } #/if $operands
+ } # /for
+ }
+
+ # add limits
+ my $limit_query;
+ my $limit_search_desc;
+ foreach my $limit (@limits) {
+
+ # FIXME: not quite right yet ... will work on this soon -- JF
+ my $type = $1 if $limit =~ m/([^:]+):([^:]*)/;
+ if ( $limit =~ /available/ ) {
+ $limit_query .=
+" (($query and datedue=0000-00-00) or ($query and datedue=0000-00-00 not lost=1) or ($query and datedue=0000-00-00 not lost=2))";
+
+ #$limit_search_desc.=" and available";
+ }
+ elsif ( ($limit_query) && ( index( $limit_query, $type, 0 ) > 0 ) ) {
+ if ( $limit_query !~ /\(/ ) {
+ $limit_query =
+ substr( $limit_query, 0, index( $limit_query, $type, 0 ) )
+ . "("
+ . substr( $limit_query, index( $limit_query, $type, 0 ) )
+ . " or $limit )"
+ if $limit;
+ $limit_search_desc =
+ substr( $limit_search_desc, 0,
+ index( $limit_search_desc, $type, 0 ) )
+ . "("
+ . substr( $limit_search_desc,
+ index( $limit_search_desc, $type, 0 ) )
+ . " or $limit )"
+ if $limit;
+ }
+ else {
+ chop $limit_query;
+ chop $limit_search_desc;
+ $limit_query .= " or $limit )" if $limit;
+ $limit_search_desc .= " or $limit )" if $limit;
+ }
+ }
+ elsif ( ($limit_query) && ( $limit =~ /mc/ ) ) {
+ $limit_query .= " or $limit" if $limit;
+ $limit_search_desc .= " or $limit" if $limit;
+ }
+
+ # these are treated as AND
+ elsif ($limit_query) {
+ $limit_query .= " and $limit" if $limit;
+ $limit_search_desc .= " and $limit" if $limit;
+ }
+
+ # otherwise, there is nothing but the limit
+ else {
+ $limit_query .= "$limit" if $limit;
+ $limit_search_desc .= "$limit" if $limit;
+ }
+ }
+
+ # if there's also a query, we need to AND the limits to it
+ if ( ($limit_query) && ($query) ) {
+ $limit_query = " and (" . $limit_query . ")";
+ $limit_search_desc = " and ($limit_search_desc)" if $limit_search_desc;
+
+ }
+ $query .= $limit_query;
+ $human_search_desc .= $limit_search_desc;
+
+ # now normalize the strings
+ $query =~ s/ / /g; # remove extra spaces
+ $query =~ s/^ //g; # remove any beginning spaces
+ $query =~ s/:/=/g; # causes probs for server
+ $query =~ s/==/=/g; # remove double == from query
+
+ my $federated_query = $human_search_desc;
+ $federated_query =~ s/ / /g;
+ $federated_query =~ s/^ //g;
+ $federated_query =~ s/:/=/g;
+ my $federated_query_opensearch = $federated_query;
+
+# my $federated_query_RPN = new ZOOM::Query::CCL2RPN( $query , C4::Context->ZConn('biblioserver'));
+
+ $human_search_desc =~ s/ / /g;
+ $human_search_desc =~ s/^ //g;
+ my $koha_query = $query;
+
+ #warn "QUERY:".$koha_query;
+ #warn "SEARCHDESC:".$human_search_desc;
+ #warn "FEDERATED QUERY:".$federated_query;
+ return ( undef, $human_search_desc, $koha_query, $federated_query );
+}
+
+# IMO this subroutine is pretty messy still -- it's responsible for
+# building the HTML output for the template
+sub searchResults {
+ my ( $searchdesc, $hits, $results_per_page, $offset, @marcresults ) = @_;
-C<$transit> is the number of items at the Transit branch (in transit
-between branches?).
+ my $dbh = C4::Context->dbh;
+ my $toggle;
+ my $even = 1;
+ my @newresults;
+ my $span_terms_hashref;
+ for my $span_term ( split( / /, $searchdesc ) ) {
+ $span_term =~ s/(.*=|\)|\(|\+|\.)//g;
+ $span_terms_hashref->{$span_term}++;
+ }
-C<$ocount> is the number of items that haven't arrived yet
-(aqorders.quantity - aqorders.quantityreceived).
+ #Build brancnames hash
+ #find branchname
+ #get branch information.....
+ my %branches;
+ my $bsth =
+ $dbh->prepare("SELECT branchcode,branchname FROM branches")
+ ; # FIXME : use C4::Koha::GetBranches
+ $bsth->execute();
+ while ( my $bdata = $bsth->fetchrow_hashref ) {
+ $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
+ }
-=cut
-#'
+ #Build itemtype hash
+ #find itemtype & itemtype image
+ my %itemtypes;
+ $bsth =
+ $dbh->prepare("SELECT itemtype,description,imageurl,summary FROM itemtypes");
+ $bsth->execute();
+ while ( my $bdata = $bsth->fetchrow_hashref ) {
+ $itemtypes{ $bdata->{'itemtype'} }->{description} =
+ $bdata->{'description'};
+ $itemtypes{ $bdata->{'itemtype'} }->{imageurl} = $bdata->{'imageurl'};
+ $itemtypes{ $bdata->{'itemtype'} }->{summary} = $bdata->{'summary'};
+ }
+ #search item field code
+ my $sth =
+ $dbh->prepare(
+"select tagfield from marc_subfield_structure where kohafield like 'items.itemnumber'"
+ );
+ $sth->execute;
+ my ($itemtag) = $sth->fetchrow;
+ ## find column names of items related to MARC
+ my $sth2 = $dbh->prepare("SHOW COLUMNS from items");
+ $sth2->execute;
+ my %subfieldstosearch;
+ while ( ( my $column ) = $sth2->fetchrow ) {
+ my ( $tagfield, $tagsubfield ) =
+ &MARCfind_marc_from_kohafield( $dbh, "items." . $column, "" );
+ $subfieldstosearch{$column} = $tagsubfield;
+ }
+ my $times;
+
+ if ( $hits && $offset + $results_per_page <= $hits ) {
+ $times = $offset + $results_per_page;
+ }
+ else {
+ $times = $hits;
+ }
+
+ for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
+ my $marcrecord;
+ $marcrecord = MARC::File::USMARC::decode( $marcresults[$i] );
+
+ my $oldbiblio = MARCmarc2koha( $dbh, $marcrecord, '' );
+
+ # add image url if there is one
+ if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} =~ /^http:/ ) {
+ $oldbiblio->{imageurl} =
+ $itemtypes{ $oldbiblio->{itemtype} }->{imageurl};
+ $oldbiblio->{description} =
+ $itemtypes{ $oldbiblio->{itemtype} }->{description};
+ }
+ else {
+ $oldbiblio->{imageurl} =
+ getitemtypeimagesrc() . "/"
+ . $itemtypes{ $oldbiblio->{itemtype} }->{imageurl}
+ if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
+ $oldbiblio->{description} =
+ $itemtypes{ $oldbiblio->{itemtype} }->{description};
+ }
+ #
+ # build summary if there is one (the summary is defined in itemtypes table
+ #
+ if ($itemtypes{ $oldbiblio->{itemtype} }->{summary}) {
+ my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
+ my @fields = $marcrecord->fields();
+ foreach my $field (@fields) {
+ my $tag = $field->tag();
+ my $tagvalue = $field->as_string();
+ $summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
+ unless ($tag<10) {
+ my @subf = $field->subfields;
+ for my $i (0..$#subf) {
+ my $subfieldcode = $subf[$i][0];
+ my $subfieldvalue = $subf[$i][1];
+ my $tagsubf = $tag.$subfieldcode;
+ $summary =~ s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
+ }
+ }
+ }
+ $summary =~ s/\[(.*?)]//g;
+ $summary =~ s/\n/<br>/g;
+ $oldbiblio->{summary} = $summary;
+ }
+ # add spans to search term in results
+ foreach my $term ( keys %$span_terms_hashref ) {
+
+ #warn "term: $term";
+ my $old_term = $term;
+ if ( length($term) > 3 ) {
+ $term =~ s/(.*=|\)|\(|\+|\.|\?)//g;
+
+ #FIXME: is there a better way to do this?
+ $oldbiblio->{'title'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'subtitle'} =~
+ s/$term/<span class=term>$&<\/span>/gi;
+
+ $oldbiblio->{'author'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'publishercode'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'place'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'pages'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'notes'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ $oldbiblio->{'size'} =~ s/$term/<span class=term>$&<\/span>/gi;
+ }
+ }
+
+ if ( $i % 2 ) {
+ $toggle = "#ffffcc";
+ }
+ else {
+ $toggle = "white";
+ }
+ $oldbiblio->{'toggle'} = $toggle;
+ my @fields = $marcrecord->field($itemtag);
+ my @items_loop;
+ my $items;
+ my $ordered_count = 0;
+ my $onloan_count = 0;
+ my $wthdrawn_count = 0;
+ my $itemlost_count = 0;
+ my $itembinding_count = 0;
+ my $norequests = 1;
+
+ foreach my $field (@fields) {
+ my $item;
+ foreach my $code ( keys %subfieldstosearch ) {
+ $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
+ }
+ if ( $item->{wthdrawn} ) {
+ $wthdrawn_count++;
+ }
+ elsif ( $item->{notforloan} == -1 ) {
+ $ordered_count++;
+ $norequests = 0;
+ }
+ elsif ( $item->{itemlost} ) {
+ $itemlost_count++;
+ }
+ elsif ( $item->{binding} ) {
+ $itembinding_count++;
+ }
+ elsif ( ( $item->{onloan} ) && ( $item->{onloan} != '0000-00-00' ) )
+ {
+ $onloan_count++;
+ $norequests = 0;
+ }
+ else {
+ $norequests = 0;
+ if ( $item->{'homebranch'} ) {
+ $items->{ $item->{'homebranch'} }->{count}++;
+ }
+
+ # Last resort
+ elsif ( $item->{'holdingbranch'} ) {
+ $items->{ $item->{'homebranch'} }->{count}++;
+ }
+ $items->{ $item->{homebranch} }->{itemcallnumber} =
+ $item->{itemcallnumber};
+ $items->{ $item->{homebranch} }->{location} =
+ $item->{location};
+ }
+ } # notforloan, item level and biblioitem level
+ for my $key ( keys %$items ) {
+
+ #warn "key: $key";
+ my $this_item = {
+ branchname => $branches{$key},
+ branchcode => $key,
+ count => $items->{$key}->{count},
+ itemcallnumber => $items->{$key}->{itemcallnumber},
+ location => $items->{$key}->{location},
+ };
+ push @items_loop, $this_item;
+ }
+ $oldbiblio->{norequests} = $norequests;
+ $oldbiblio->{items_loop} = \@items_loop;
+ $oldbiblio->{onloancount} = $onloan_count;
+ $oldbiblio->{wthdrawncount} = $wthdrawn_count;
+ $oldbiblio->{itemlostcount} = $itemlost_count;
+ $oldbiblio->{bindingcount} = $itembinding_count;
+ $oldbiblio->{orderedcount} = $ordered_count;
+
+# FIXME
+# Ugh ... this is ugly, I'll re-write it better above then delete it
+# my $norequests = 1;
+# my $noitems = 1;
+# if (@items) {
+# $noitems = 0;
+# foreach my $itm (@items) {
+# $norequests = 0 unless $itm->{'itemnotforloan'};
+# }
+# }
+# $oldbiblio->{'noitems'} = $noitems;
+# $oldbiblio->{'norequests'} = $norequests;
+# $oldbiblio->{'even'} = $even = not $even;
+# $oldbiblio->{'itemcount'} = $counts{'total'};
+# my $totalitemcounts = 0;
+# foreach my $key (keys %counts){
+# if ($key ne 'total'){
+# $totalitemcounts+= $counts{$key};
+# $oldbiblio->{'locationhash'}->{$key}=$counts{$key};
+# }
+# }
+# my ($locationtext, $locationtextonly, $notavailabletext) = ('','','');
+# foreach (sort keys %{$oldbiblio->{'locationhash'}}) {
+# if ($_ eq 'notavailable') {
+# $notavailabletext="Not available";
+# my $c=$oldbiblio->{'locationhash'}->{$_};
+# $oldbiblio->{'not-available-p'}=$c;
+# } else {
+# $locationtext.="$_";
+# my $c=$oldbiblio->{'locationhash'}->{$_};
+# if ($_ eq 'Item Lost') {
+# $oldbiblio->{'lost-p'} = $c;
+# } elsif ($_ eq 'Withdrawn') {
+# $oldbiblio->{'withdrawn-p'} = $c;
+# } elsif ($_ eq 'On Loan') {
+# $oldbiblio->{'on-loan-p'} = $c;
+# } else {
+# $locationtextonly.= $_;
+# $locationtextonly.= " ($c)<br/> " if $totalitemcounts > 1;
+# }
+# if ($totalitemcounts>1) {
+# $locationtext.=" ($c)<br/> ";
+# }
+# }
+# }
+# if ($notavailabletext) {
+# $locationtext.= $notavailabletext;
+# } else {
+# $locationtext=~s/, $//;
+# }
+# $oldbiblio->{'location'} = $locationtext;
+# $oldbiblio->{'location-only'} = $locationtextonly;
+# $oldbiblio->{'use-location-flags-p'} = 1;
-sub itemcount {
- my ($env,$bibnum,$type)=@_;
- my $dbh = C4::Context->dbh;
-my @kohafield;
-my @value;
-my @relation;
-my @and_or;
-my $sort;
- my $query="Select * from items where
- biblionumber=? ";
-push @kohafield,"biblionumber";
-push @value,$bibnum;
-
-my ($total, at result)=ZEBRAsearch_kohafields(\@kohafield,\@value, \@relation,"", \@and_or, 0);## there is only one record no need for $num or $offset
-my @fields;## extract only the fields required
-push @fields,"itemnumber","itemlost","wthdrawn","holdingbranch","date_due";
-my ($biblio, at items)=XMLmarc2koha ($dbh,$result[0],"holdings",\@fields);
- my $count=0;
- my $lcount=0;
- my $nacount=0;
- my $fcount=0;
- my $scount=0;
- my $lostcount=0;
- my $mending=0;
- my $transit=0;
- my $ocount=0;
- foreach my $data(@items){
- if ($type ne "intra"){
- next if ($data->{itemlost} || $data->{wthdrawn});
- } ## Probably trying to hide lost item from opac ?
- $count++;
-
-## Now it seems we want to find those which are onloan
-
-
- if ( $data->{date_due} gt "0000-00-00"){
- $nacount++;
- next;
- }
-### The rest of this code is hardcoded for Foxtrot Shanon etc. We urgently need a global understanding of these terms--TG
- if ($data->{'holdingbranch'} eq 'C' || $data->{'holdingbranch'} eq 'LT'){
- $lcount++;
- }
- if ($data->{'holdingbranch'} eq 'F' || $data->{'holdingbranch'} eq 'FP'){
- $fcount++;
- }
- if ($data->{'holdingbranch'} eq 'S' || $data->{'holdingbranch'} eq 'SP'){
- $scount++;
- }
- if ($data->{'itemlost'} eq '1'){
- $lostcount++;
- }
- if ($data->{'itemlost'} eq '2'){
- $lostcount++;
- }
- if ($data->{'holdingbranch'} eq 'FM'){
- $mending++;
- }
- if ($data->{'holdingbranch'} eq 'TR'){
- $transit++;
- }
-
- }
-# if ($count == 0){
- my $sth2=$dbh->prepare("Select * from aqorders where biblionumber=?");
- $sth2->execute($bibnum);
- if (my $data=$sth2->fetchrow_hashref){
- $ocount=$data->{'quantity'} - $data->{'quantityreceived'};
+ push( @newresults, $oldbiblio );
}
-# $count+=$ocount;
-
- return ($count,$lcount,$nacount,$fcount,$scount,$lostcount,$mending,$transit,$ocount);
+ return @newresults;
}
-sub spellSuggest {
-my ($kohafield,$value)=@_;
- if (@$kohafield[0] eq "title" || @$kohafield[0] eq "author" || @$kohafield eq "subject"){
-## pass them through
-}else{
- @$kohafield[0]="any";
-}
-my $kohaattr=MARCfind_attr_from_kohafield(@$kohafield[0]);
-@$value[0]=~ s/(\.|\?|\;|\=|\/|\\|\||\:|\*|\!|\,|\(|\)|\[|\]|\{|\}|\/)/ /g;
-my $query= $kohaattr." \@attr 6=3 \"".@$value[0]."\"";
-my @zconn;
- $zconn[0]=C4::Context->Zconn("biblioserver");
-$zconn[0]->option(number=>5);
-my $result=$zconn[0]->scan_pqf($query);
-my $i;
-my $event;
- while (($i = ZOOM::event(\@zconn)) != 0) {
- $event = $zconn[$i-1]->last_event();
- last if $event == ZOOM::Event::ZEND;
- }# whilemy $i;
-
-my $n=$result->size();
-
-my @suggestion;
-for (my $i=0; $i<$n; $i++){
-my ($term,$occ)=$result->term($i);
-push @suggestion, {kohafield=>@$kohafield[0], value=>$term,occ=>$occ} unless $term=~/\@/;
-}
-$zconn[0]->destroy();
-return @suggestion;
-}
END { } # module clean-up code here (global destructor)
1;
__END__
-=back
-
=head1 AUTHOR
Koha Developement team <info at koha.org>
-# New functions to comply with ZEBRA search and new KOHA 3 XML API added 2006 Tumer Garip tgarip at neu.edu.tr
=cut
Index: Serials.pm
===================================================================
RCS file: /sources/koha/koha/C4/Serials.pm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -b -r1.11 -r1.12
--- Serials.pm 15 Nov 2006 01:36:00 -0000 1.11
+++ Serials.pm 9 Mar 2007 14:31:47 -0000 1.12
@@ -17,22 +17,27 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Serials.pm,v 1.11 2006/11/15 01:36:00 tgarip1957 Exp $
+# $Id: Serials.pm,v 1.12 2007/03/09 14:31:47 tipaul Exp $
use strict;
use C4::Date;
+use Date::Calc qw(:all);
+use POSIX qw(strftime);
use C4::Suggestions;
+use C4::Koha;
use C4::Biblio;
use C4::Search;
use C4::Letters;
+use C4::Log; # logaction
+
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.11 $' =~ /\d+/g;
- shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
-
+$VERSION = do { my @v = '$Revision: 1.12 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -49,19 +54,29 @@
=head1 FUNCTIONS
=cut
+
@ISA = qw(Exporter);
@EXPORT = qw(
- &NewSubscription &ModSubscription &DelSubscription &GetSubscriptions &GetSubscription
- &CountSubscriptionFromBiblionumber &GetSubscriptionsFromBiblionumber
- &GetFullSubscriptionsFromBiblionumber &GetNextSeq
- &ModSubscriptionHistory &NewIssue
- &GetSerials &GetLatestSerials &ModSerialStatus
- &HasSubscriptionExpired &GetSubscriptionExpirationDate &ReNewSubscription
- &GetSuppliersWithLateIssues &GetLateIssues &GetMissingIssues
- &GetDistributedTo &SetDistributedto
- &getroutinglist &delroutingmember &addroutingmember &reorder_members
- &check_routing &getsupplierbyserialid &updateClaim &removeMissingIssue &abouttoexpire
- &Get_Next_Date
+
+ &NewSubscription &ModSubscription &DelSubscription &GetSubscriptions
+ &GetSubscription &CountSubscriptionFromBiblionumber &GetSubscriptionsFromBiblionumber
+ &GetFullSubscriptionsFromBiblionumber &GetFullSubscription &ModSubscriptionHistory
+ &HasSubscriptionExpired &GetExpirationDate &abouttoexpire
+
+ &GetNextSeq &NewIssue &ItemizeSerials &GetSerials
+ &GetLatestSerials &ModSerialStatus &GetNextDate &GetSerials2
+ &ReNewSubscription &GetLateIssues &GetLateOrMissingIssues
+ &GetSerialInformation &AddItem2Serial
+ &PrepareSerialsData
+
+ &UpdateClaimdateIssues
+ &GetSuppliersWithLateIssues &getsupplierbyserialid
+ &GetDistributedTo &SetDistributedTo
+ &getroutinglist &delroutingmember &addroutingmember
+ &reorder_members
+ &check_routing &updateClaim &removeMissingIssue
+
+ &old_newsubscription &old_modsubscription &old_getserials
);
=head2 GetSuppliersWithLateIssues
@@ -78,6 +93,7 @@
=back
=cut
+
sub GetSuppliersWithLateIssues {
my $dbh = C4::Context->dbh;
my $query = qq|
@@ -90,10 +106,10 @@
my $sth = $dbh->prepare($query);
$sth->execute;
my %supplierlist;
- while (my ($id,$name) = $sth->fetchrow) {
+ while ( my ( $id, $name ) = $sth->fetchrow ) {
$supplierlist{$id} = $name;
}
- if(C4::Context->preference("RoutingSerials")){
+ if ( C4::Context->preference("RoutingSerials") ) {
$supplierlist{''} = "All Suppliers";
}
return %supplierlist;
@@ -114,12 +130,13 @@
=back
=cut
+
sub GetLateIssues {
- my ($supplierid) = shift;
+ my ($supplierid) = @_;
my $dbh = C4::Context->dbh;
my $sth;
if ($supplierid) {
- my $query = qq |
+ my $query = qq|
SELECT name,title,planneddate,serialseq,serial.subscriptionid
FROM subscription, serial, biblio
LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
@@ -130,7 +147,8 @@
ORDER BY title
|;
$sth = $dbh->prepare($query);
- } else {
+ }
+ else {
my $query = qq|
SELECT name,title,planneddate,serialseq,serial.subscriptionid
FROM subscription, serial, biblio
@@ -145,18 +163,17 @@
$sth->execute;
my @issuelist;
my $last_title;
- my $odd=0;
- my $count=0;
- while (my $line = $sth->fetchrow_hashref) {
+ my $odd = 0;
+ my $count = 0;
+ while ( my $line = $sth->fetchrow_hashref ) {
$odd++ unless $line->{title} eq $last_title;
$line->{title} = "" if $line->{title} eq $last_title;
- $last_title = $line->{title} if ($line->{title});
- $line->{planneddate} = format_date($line->{planneddate});
- $line->{'odd'} = 1 if $odd %2 ;
+ $last_title = $line->{title} if ( $line->{title} );
+ $line->{planneddate} = format_date( $line->{planneddate} );
$count++;
- push @issuelist,$line;
+ push @issuelist, $line;
}
- return $count, at issuelist;
+ return $count, @issuelist;
}
=head2 GetSubscriptionHistoryFromSubscriptionId
@@ -172,6 +189,7 @@
=back
=cut
+
sub GetSubscriptionHistoryFromSubscriptionId() {
my $dbh = C4::Context->dbh;
my $query = qq|
@@ -195,7 +213,8 @@
=back
=cut
-sub GetSerialStatusFromSerialId(){
+
+sub GetSerialStatusFromSerialId() {
my $dbh = C4::Context->dbh;
my $query = qq|
SELECT status
@@ -205,6 +224,114 @@
return $dbh->prepare($query);
}
+=head2 GetSerialInformation
+
+=over 4
+
+$data = GetSerialInformation($serialid);
+returns a hash containing :
+ items : items marcrecord (can be an array)
+ serial table field
+ subscription table field
+ + information about subscription expiration
+
+=back
+
+=cut
+
+sub GetSerialInformation {
+ my ($serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT serial.*, serial.notes as sernotes, serial.status as serstatus,subscription.*,subscription.subscriptionid as subsid
+ FROM serial LEFT JOIN subscription ON subscription.subscriptionid=serial.subscriptionid
+ WHERE serialid = ?
+ |;
+ my $rq = $dbh->prepare($query);
+ $rq->execute($serialid);
+ my $data = $rq->fetchrow_hashref;
+
+ if ( C4::Context->preference("serialsadditems") ) {
+ if ( $data->{'itemnumber'} ) {
+ my @itemnumbers = split /,/, $data->{'itemnumber'};
+ foreach my $itemnum (@itemnumbers) {
+
+ #It is ASSUMED that MARCgetitem ALWAYS WORK...
+ #Maybe MARCgetitem should return values on failure
+# warn "itemnumber :$itemnum, bibnum :".$data->{'biblionumber'};
+ my $itemprocessed =
+ PrepareItemrecordDisplay( $data->{'biblionumber'}, $itemnum );
+ $itemprocessed->{'itemnumber'} = $itemnum;
+ $itemprocessed->{'itemid'} = $itemnum;
+ $itemprocessed->{'serialid'} = $serialid;
+ $itemprocessed->{'biblionumber'} = $data->{'biblionumber'};
+ push @{ $data->{'items'} }, $itemprocessed;
+ }
+ }
+ else {
+ my $itemprocessed =
+ PrepareItemrecordDisplay( $data->{'biblionumber'} );
+ $itemprocessed->{'itemid'} = "N$serialid";
+ $itemprocessed->{'serialid'} = $serialid;
+ $itemprocessed->{'biblionumber'} = $data->{'biblionumber'};
+ $itemprocessed->{'countitems'} = 0;
+ push @{ $data->{'items'} }, $itemprocessed;
+ }
+ }
+ $data->{ "status" . $data->{'serstatus'} } = 1;
+ $data->{'subscriptionexpired'} =
+ HasSubscriptionExpired( $data->{'subscriptionid'} ) && $data->{'status'}==1;
+ $data->{'abouttoexpire'} =
+ abouttoexpire( $data->{'subscriptionid'} );
+ return $data;
+}
+
+=head2 GetSerialInformation
+
+=over 4
+
+$data = AddItem2Serial($serialid,$itemnumber);
+Adds an itemnumber to Serial record
+=back
+
+=cut
+
+sub AddItem2Serial {
+ my ( $serialid, $itemnumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ UPDATE serial SET itemnumber=IF(itemnumber IS NULL, $itemnumber, CONCAT(itemnumber,",",$itemnumber))
+ WHERE serialid = ?
+ |;
+ my $rq = $dbh->prepare($query);
+ $rq->execute($serialid);
+ return $rq->rows;
+}
+
+=head2 UpdateClaimdateIssues
+
+=over 4
+
+UpdateClaimdateIssues($serialids,[$date]);
+
+Update Claimdate for issues in @$serialids list with date $date
+(Take Today if none)
+=back
+
+=cut
+
+sub UpdateClaimdateIssues {
+ my ( $serialids, $date ) = @_;
+ my $dbh = C4::Context->dbh;
+ $date = strftime("%Y-%m-%d",localtime) unless ($date);
+ my $query = "
+ UPDATE serial SET claimdate=$date,status=7
+ WHERE serialid in ".join (",",@$serialids);
+ ;
+ my $rq = $dbh->prepare($query);
+ $rq->execute;
+ return $rq->rows;
+}
=head2 GetSubscription
@@ -219,15 +346,17 @@
=back
=cut
+
sub GetSubscription {
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
- my $query =qq(
+ my $query = qq(
SELECT subscription.*,
subscriptionhistory.*,
aqbudget.bookfundid,
aqbooksellers.name AS aqbooksellername,
- biblio.title AS bibliotitle
+ biblio.title AS bibliotitle,
+ subscription.biblionumber as bibnum
FROM subscription
LEFT JOIN subscriptionhistory ON subscription.subscriptionid=subscriptionhistory.subscriptionid
LEFT JOIN aqbudget ON subscription.aqbudgetid=aqbudget.aqbudgetid
@@ -235,31 +364,150 @@
LEFT JOIN biblio ON biblio.biblionumber=subscription.biblionumber
WHERE subscription.subscriptionid = ?
);
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+# warn "flags: ".C4::Context->userenv->{'flags'};
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+# warn "query : $query";
my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
my $subs = $sth->fetchrow_hashref;
return $subs;
}
-=head2 GetSubscriptionsFromBiblionumber
+=head2 GetFullSubscription
+
+=over 4
+
+ \@res = GetFullSubscription($subscriptionid)
+ this function read on serial table.
+
+=back
+
+=cut
+
+sub GetFullSubscription {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT serial.serialid,
+ serial.serialseq,
+ serial.planneddate,
+ serial.publisheddate,
+ serial.status,
+ serial.notes as notes,
+ year(IF(serial.publisheddate="00-00-0000",serial.planneddate,serial.publisheddate)) as year,
+ aqbudget.bookfundid,aqbooksellers.name as aqbooksellername,
+ biblio.title as bibliotitle,
+ subscription.branchcode AS branchcode,
+ subscription.subscriptionid AS subscriptionid
+ FROM serial
+ LEFT JOIN subscription ON
+ (serial.subscriptionid=subscription.subscriptionid AND subscription.biblionumber=serial.biblionumber)
+ LEFT JOIN aqbudget ON subscription.aqbudgetid=aqbudget.aqbudgetid
+ LEFT JOIN aqbooksellers on subscription.aqbooksellerid=aqbooksellers.id
+ LEFT JOIN biblio on biblio.biblionumber=subscription.biblionumber
+ WHERE serial.subscriptionid = ? |;
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.="
+ AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query .=qq|
+ ORDER BY year DESC,
+ IF(serial.publisheddate="00-00-0000",serial.planneddate,serial.publisheddate) DESC,
+ serial.subscriptionid
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $subs = $sth->fetchall_arrayref({});
+ return $subs;
+}
+
+
+=head2 PrepareSerialsData
=over 4
+ \@res = PrepareSerialsData($serialinfomation)
+ where serialinformation is a hashref array
+
+=back
+
+=cut
+
+sub PrepareSerialsData{
+ my ($lines)=@_;
+ my %tmpresults;
+ my $year;
+ my @res;
+ my $startdate;
+ my $aqbooksellername;
+ my $bibliotitle;
+ my @loopissues;
+ my $first;
+ my $previousnote = "";
+
+ foreach my $subs ( @$lines ) {
+ $subs->{'publisheddate'} =
+ ( $subs->{'publisheddate'}
+ ? format_date( $subs->{'publisheddate'} )
+ : "XXX" );
+ $subs->{'planneddate'} = format_date( $subs->{'planneddate'} );
+ $subs->{ "status" . $subs->{'status'} } = 1;
+
+# $subs->{'notes'} = $subs->{'notes'} eq $previousnote?"":$subs->{notes};
+ if ( $subs->{'year'} && $subs->{'year'} ne "" ) {
+ $year = $subs->{'year'};
+ }
+ else {
+ $year = "manage";
+ }
+ if ( $tmpresults{$year} ) {
+ push @{ $tmpresults{$year}->{'serials'} }, $subs;
+ }
+ else {
+ $tmpresults{$year} = {
+ 'year' => $year,
+
+ # 'startdate'=>format_date($subs->{'startdate'}),
+ 'aqbooksellername' => $subs->{'aqbooksellername'},
+ 'bibliotitle' => $subs->{'bibliotitle'},
+ 'serials' => [$subs],
+ 'first' => $first,
+ 'branchcode' => $subs->{'branchcode'},
+ 'subscriptionid' => $subs->{'subscriptionid'},
+ };
+ }
+
+ # $previousnote=$subs->{notes};
+ }
+ foreach my $key ( sort { $b cmp $a } keys %tmpresults ) {
+ push @res, $tmpresults{$key};
+ }
+ return \@res;
+}
+
+=head2 GetSubscriptionsFromBiblionumber
+
\@res = GetSubscriptionsFromBiblionumber($biblionumber)
this function get the subscription list. it reads on subscription table.
return :
table of subscription which has the biblionumber given on input arg.
each line of this table is a hashref. All hashes containt
-planned, histstartdate,opacnote,missinglist,receivedlist,periodicity,status & enddate
-
-=back
+startdate, histstartdate,opacnote,missinglist,recievedlist,periodicity,status & enddate
=cut
+
sub GetSubscriptionsFromBiblionumber {
my ($biblionumber) = @_;
my $dbh = C4::Context->dbh;
my $query = qq(
SELECT subscription.*,
+ branches.branchname,
subscriptionhistory.*,
aqbudget.bookfundid,
aqbooksellers.name AS aqbooksellername,
@@ -269,29 +517,39 @@
LEFT JOIN aqbudget ON subscription.aqbudgetid=aqbudget.aqbudgetid
LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
LEFT JOIN biblio ON biblio.biblionumber=subscription.biblionumber
+ LEFT JOIN branches ON branches.branchcode=subscription.branchcode
WHERE subscription.biblionumber = ?
);
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
my @res;
- while (my $subs = $sth->fetchrow_hashref) {
- $subs->{planneddate} = format_date($subs->{planneddate});
- $subs->{publisheddate} = format_date($subs->{publisheddate});
- $subs->{histstartdate} = format_date($subs->{histstartdate});
+ while ( my $subs = $sth->fetchrow_hashref ) {
+ $subs->{startdate} = format_date( $subs->{startdate} );
+ $subs->{histstartdate} = format_date( $subs->{histstartdate} );
$subs->{opacnote} =~ s/\n/\<br\/\>/g;
$subs->{missinglist} =~ s/\n/\<br\/\>/g;
- $subs->{receivedlist} =~ s/\n/\<br\/\>/g;
- $subs->{"periodicity".$subs->{periodicity}} = 1;
- $subs->{"status".$subs->{'status'}} = 1;
- if ($subs->{enddate} eq '0000-00-00') {
- $subs->{enddate}='';
- } else {
- $subs->{enddate} = format_date($subs->{enddate});
+ $subs->{recievedlist} =~ s/\n/\<br\/\>/g;
+ $subs->{ "periodicity" . $subs->{periodicity} } = 1;
+ $subs->{ "numberpattern" . $subs->{numberpattern} } = 1;
+ $subs->{ "status" . $subs->{'status'} } = 1;
+ if ( $subs->{enddate} eq '0000-00-00' ) {
+ $subs->{enddate} = '';
+ }
+ else {
+ $subs->{enddate} = format_date( $subs->{enddate} );
}
- push @res,$subs;
+ $subs->{'abouttoexpire'}=abouttoexpire($subs->{'subscriptionid'});
+ $subs->{'subscriptionexpired'}=HasSubscriptionExpired($subs->{'subscriptionid'});
+ push @res, $subs;
}
return \@res;
}
+
=head2 GetFullSubscriptionsFromBiblionumber
=over 4
@@ -302,81 +560,46 @@
=back
=cut
+
sub GetFullSubscriptionsFromBiblionumber {
my ($biblionumber) = @_;
my $dbh = C4::Context->dbh;
- my $query=qq|
- SELECT serial.serialseq,
+ my $query = qq|
+ SELECT serial.serialid,
+ serial.serialseq,
serial.planneddate,
serial.publisheddate,
serial.status,
- serial.notes,
- year(serial.publisheddate) AS year,
- aqbudget.bookfundid,aqbooksellers.name AS aqbooksellername,
- biblio.title AS bibliotitle
+ serial.notes as notes,
+ year(IF(serial.publisheddate="00-00-0000",serial.planneddate,serial.publisheddate)) as year,
+ aqbudget.bookfundid,aqbooksellers.name as aqbooksellername,
+ biblio.title as bibliotitle,
+ subscription.branchcode AS branchcode,
+ subscription.subscriptionid AS subscriptionid
FROM serial
LEFT JOIN subscription ON
(serial.subscriptionid=subscription.subscriptionid AND subscription.biblionumber=serial.biblionumber)
LEFT JOIN aqbudget ON subscription.aqbudgetid=aqbudget.aqbudgetid
LEFT JOIN aqbooksellers on subscription.aqbooksellerid=aqbooksellers.id
LEFT JOIN biblio on biblio.biblionumber=subscription.biblionumber
- WHERE subscription.biblionumber = ?
- ORDER BY year,serial.publisheddate,serial.subscriptionid,serial.planneddate
+ WHERE subscription.biblionumber = ? |;
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.="
+ AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query .=qq|
+ ORDER BY year DESC,
+ IF(serial.publisheddate="00-00-0000",serial.planneddate,serial.publisheddate) DESC,
+ serial.subscriptionid
|;
-
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
- my @res;
- my $year;
- my $startdate;
- my $aqbooksellername;
- my $bibliotitle;
- my @loopissues;
- my $first;
- my $previousnote="";
- while (my $subs = $sth->fetchrow_hashref) {
- ### BUG To FIX: When there is no published date, will create many null ids!!!
-
- if ($year and ($year==$subs->{year})){
- if ($first eq 1){$first=0;}
- my $temp=$res[scalar(@res)-1]->{'serials'};
- push @$temp,
- {'publisheddate' =>format_date($subs->{'publisheddate'}),
- 'planneddate' => format_date($subs->{'planneddate'}),
- 'serialseq' => $subs->{'serialseq'},
- "status".$subs->{'status'} => 1,
- 'notes' => $subs->{'notes'} eq $previousnote?"":$subs->{notes},
- };
- } else {
- $first=1 if (not $year);
- $year= $subs->{'year'};
- $startdate= format_date($subs->{'startdate'});
- $aqbooksellername= $subs->{'aqbooksellername'};
- $bibliotitle= $subs->{'bibliotitle'};
- my @temp;
- push @temp,
- {'publisheddate' =>format_date($subs->{'publisheddate'}),
- 'planneddate' => format_date($subs->{'planneddate'}),
- 'serialseq' => $subs->{'serialseq'},
- "status".$subs->{'status'} => 1,
- 'notes' => $subs->{'notes'} eq $previousnote?"":$subs->{notes},
- };
-
- push @res,{
- 'year'=>$year,
- 'startdate'=>$startdate,
- 'aqbooksellername'=>$aqbooksellername,
- 'bibliotitle'=>$bibliotitle,
- 'serials'=>\@temp,
- 'first'=>$first
- };
- }
- $previousnote=$subs->{notes};
- }
- return \@res;
+ my $subs= $sth->fetchall_arrayref({});
+ return $subs;
}
-
=head2 GetSubscriptions
=over 4
@@ -389,76 +612,99 @@
=back
=cut
+
sub GetSubscriptions {
- my ($title,$ISSN,$biblionumber,$supplierid) = @_;
- return unless $title or $ISSN or $biblionumber or $supplierid;
+ my ( $title, $ISSN, $biblionumber ) = @_;
+ #return unless $title or $ISSN or $biblionumber;
my $dbh = C4::Context->dbh;
my $sth;
if ($biblionumber) {
my $query = qq(
- SELECT subscription.subscriptionid,biblio.title,biblio.issn,subscription.notes,biblio.biblionumber
- FROM subscription,biblio
- WHERE biblio.biblionumber = subscription.biblionumber
+ SELECT subscription.subscriptionid,biblio.title,biblioitems.issn,subscription.notes,subscription.branchcode,biblio.biblionumber
+ FROM subscription,biblio,biblioitems
+ WHERE biblio.biblionumber = biblioitems.biblionumber
+ AND biblio.biblionumber = subscription.biblionumber
AND biblio.biblionumber=?
- ORDER BY title
);
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query.=" ORDER BY title";
+# warn "query :$query";
$sth = $dbh->prepare($query);
$sth->execute($biblionumber);
- } elsif ($ISSN and $title){
+ }
+ else {
+ if ( $ISSN and $title ) {
my $query = qq|
- SELECT subscription.subscriptionid,biblio.title,biblio.issn,subscription.notes,biblio.biblionumber,aqbooksellerid
- FROM subscription,biblio
- WHERE biblio.biblionumber= subscription.biblionumber
- AND (biblio.title LIKE ? or biblio.issn = ?)
- ORDER BY title
- |;
- $sth = $dbh->prepare($query);
- $sth->execute("%$title%",$ISSN);
- } elsif ($ISSN){
- my $query = qq(
- SELECT subscription.subscriptionid,biblio.title,biblio.issn,subscription.notes,biblio.biblionumber,aqbooksellerid
- FROM subscription,biblio
- WHERE biblio.biblionumber=subscription.biblionumber
- AND biblio.issn = ?
- ORDER BY title
- );
+ SELECT subscription.subscriptionid,biblio.title,biblioitems.issn,subscription.notes,subscription.branchcode,biblio.biblionumber
+ FROM subscription,biblio,biblioitems
+ WHERE biblio.biblionumber = biblioitems.biblionumber
+ AND biblio.biblionumber= subscription.biblionumber
+ AND (biblio.title LIKE ? or biblioitems.issn = ?)
+ |;
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query.=" ORDER BY title";
$sth = $dbh->prepare($query);
- $sth->execute($ISSN);
- }elsif ($supplierid){
+ $sth->execute( "%$title%", $ISSN );
+ }
+ else {
+ if ($ISSN) {
my $query = qq(
- SELECT subscription.subscriptionid,biblio.title,biblio.issn,subscription.notes,biblio.biblionumber,aqbooksellerid
- FROM subscription,biblio
- WHERE biblio.biblionumber=subscription.biblionumber
- AND subscription.aqbooksellerid = ?
- ORDER BY title
+ SELECT subscription.subscriptionid,biblio.title,biblioitems.issn,subscription.notes,subscription.branchcode,biblio.biblionumber
+ FROM subscription,biblio,biblioitems
+ WHERE biblio.biblionumber = biblioitems.biblionumber
+ AND biblio.biblionumber=subscription.biblionumber
+ AND biblioitems.issn LIKE ?
);
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query.=" ORDER BY title";
+# warn "query :$query";
$sth = $dbh->prepare($query);
- $sth->execute($supplierid);
- } else {
+ $sth->execute( "%" . $ISSN . "%" );
+ }
+ else {
my $query = qq(
- SELECT subscription.subscriptionid,biblio.title,biblio.issn,subscription.notes,biblio.biblionumber,aqbooksellerid
- FROM subscription,biblio
- WHERE biblio.biblionumber=subscription.biblionumber
+ SELECT subscription.subscriptionid,biblio.title,biblioitems.issn,subscription.notes,subscription.branchcode,biblio.biblionumber
+ FROM subscription,biblio,biblioitems
+ WHERE biblio.biblionumber = biblioitems.biblionumber
+ AND biblio.biblionumber=subscription.biblionumber
AND biblio.title LIKE ?
- ORDER BY title
);
+ if (C4::Context->preference('IndependantBranches') &&
+ C4::Context->userenv &&
+ C4::Context->userenv->{'flags'} != 1){
+ $query.=" AND subscription.branchcode IN ('".C4::Context->userenv->{'branch'}."',\"''\")";
+ }
+ $query.=" ORDER BY title";
$sth = $dbh->prepare($query);
- $sth->execute("%$title%");
+ $sth->execute( "%" . $title . "%" );
+ }
+ }
}
-
-
my @results;
- my $previoustitle="";
- my $odd=1;
- while (my $line = $sth->fetchrow_hashref) {
- if ($previoustitle eq $line->{title}) {
- $line->{title}="";
- $line->{issn}="";
- $line->{toggle} = 1 if $odd==1;
- } else {
- $previoustitle=$line->{title};
- $odd=-$odd;
- $line->{toggle} = 1 if $odd==1;
+ my $previoustitle = "";
+ my $odd = 1;
+ while ( my $line = $sth->fetchrow_hashref ) {
+ if ( $previoustitle eq $line->{title} ) {
+ $line->{title} = "";
+ $line->{issn} = "";
+ $line->{toggle} = 1 if $odd == 1;
+ }
+ else {
+ $previoustitle = $line->{title};
+ $odd = -$odd;
+ $line->{toggle} = 1 if $odd == 1;
}
push @results, $line;
}
@@ -477,52 +723,87 @@
=back
=cut
+
sub GetSerials {
- my ($subscriptionid) = @_;
+ my ($subscriptionid,$count) = @_;
my $dbh = C4::Context->dbh;
- my $counter=0;
- my @serials;
-
# status = 2 is "arrived"
- my $query = qq|
- SELECT *
+ my $counter = 0;
+ $count=5 unless ($count);
+ my @serials;
+ my $query =
+ "SELECT serialid,serialseq, status, publisheddate, planneddate,notes
FROM serial
WHERE subscriptionid = ? AND status NOT IN (2,4,5)
- |;
- my $sth=$dbh->prepare($query);
+ ORDER BY publisheddate,serialid DESC";
+ my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
- while(my $line = $sth->fetchrow_hashref) {
- $line->{"status".$line->{status}} = 1; # fills a "statusX" value, used for template status select list
- $line->{"publisheddate"} = format_date($line->{"publisheddate"});
- $line->{"planneddate"} = format_date($line->{"planneddate"});
- push @serials,$line;
- }
- # OK, now add the last 5 issues arrived/missing
- my $query = qq|
- SELECT *
+ while ( my $line = $sth->fetchrow_hashref ) {
+ $line->{ "status" . $line->{status} } =
+ 1; # fills a "statusX" value, used for template status select list
+ $line->{"publisheddate"} = format_date( $line->{"publisheddate"} );
+ $line->{"planneddate"} = format_date( $line->{"planneddate"} );
+ push @serials, $line;
+ }
+ # OK, now add the last 5 issues arrives/missing
+ $query =
+ "SELECT serialid,serialseq, status, planneddate, publisheddate,notes
FROM serial
WHERE subscriptionid = ?
AND (status in (2,4,5))
- ORDER BY serialid DESC
- |;
- my $sth=$dbh->prepare($query);
+ ORDER BY publisheddate,serialid DESC
+ ";
+ $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
- while((my $line = $sth->fetchrow_hashref) && $counter <5) {
+ while ( ( my $line = $sth->fetchrow_hashref ) && $counter < $count ) {
$counter++;
+ $line->{ "status" . $line->{status} } =
+ 1; # fills a "statusX" value, used for template status select list
+ $line->{"planneddate"} = format_date( $line->{"planneddate"} );
+ $line->{"publisheddate"} = format_date( $line->{"publisheddate"} );
+ push @serials, $line;
+ }
+
+ $query = "SELECT count(*) FROM serial WHERE subscriptionid=?";
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($totalissues) = $sth->fetchrow;
+ return ( $totalissues, @serials );
+}
+
+=head2 GetSerials
+
+=over 4
+
+($totalissues, at serials) = GetSerials2($subscriptionid,$status);
+this function get every serial waited for a given subscription
+as well as the number of issues registered in the database (all types)
+this number is used to see if a subscription can be deleted (=it must have only 1 issue)
+
+=back
+
+=cut
+sub GetSerials2 {
+ my ($subscription,$status) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT serialid,serialseq, status, planneddate, publisheddate,notes
+ FROM serial
+ WHERE subscriptionid=$subscription AND status=$status
+ ORDER BY publisheddate,serialid DESC
+ |;
+# warn $query;
+ my $sth=$dbh->prepare($query);
+ $sth->execute;
+ my @serials;
+ while(my $line = $sth->fetchrow_hashref) {
$line->{"status".$line->{status}} = 1; # fills a "statusX" value, used for template status select list
$line->{"planneddate"} = format_date($line->{"planneddate"});
$line->{"publisheddate"} = format_date($line->{"publisheddate"});
push @serials,$line;
}
- my $query = qq|
- SELECT count(*)
- FROM serial
- WHERE subscriptionid=?
- |;
- $sth=$dbh->prepare($query);
- $sth->execute($subscriptionid);
- my ($totalissues) = $sth->fetchrow;
+ my ($totalissues) = scalar(@serials);
return ($totalissues, at serials);
}
@@ -538,33 +819,36 @@
=back
=cut
+
sub GetLatestSerials {
- my ($subscriptionid,$limit) = @_;
+ my ( $subscriptionid, $limit ) = @_;
my $dbh = C4::Context->dbh;
+
# status = 2 is "arrived"
- my $strsth=qq(
- SELECT serialid,serialseq, status, planneddate
+ my $strsth = "SELECT serialid,serialseq, status, planneddate, notes
FROM serial
WHERE subscriptionid = ?
AND (status =2 or status=4)
ORDER BY planneddate DESC LIMIT 0,$limit
- );
- my $sth=$dbh->prepare($strsth);
+ ";
+ my $sth = $dbh->prepare($strsth);
$sth->execute($subscriptionid);
my @serials;
- while(my $line = $sth->fetchrow_hashref) {
- $line->{"status".$line->{status}} = 1; # fills a "statusX" value, used for template status select list
- $line->{"planneddate"} = format_date($line->{"planneddate"});
- push @serials,$line;
+ while ( my $line = $sth->fetchrow_hashref ) {
+ $line->{ "status" . $line->{status} } =
+ 1; # fills a "statusX" value, used for template status select list
+ $line->{"planneddate"} = format_date( $line->{"planneddate"} );
+ push @serials, $line;
}
-# my $query = qq|
-# SELECT count(*)
-# FROM serial
-# WHERE subscriptionid=?
-# |;
-# $sth=$dbh->prepare($query);
-# $sth->execute($subscriptionid);
-# my ($totalissues) = $sth->fetchrow;
+
+ # my $query = qq|
+ # SELECT count(*)
+ # FROM serial
+ # WHERE subscriptionid=?
+ # |;
+ # $sth=$dbh->prepare($query);
+ # $sth->execute($subscriptionid);
+ # my ($totalissues) = $sth->fetchrow;
return \@serials;
}
@@ -578,15 +862,12 @@
=back
=cut
+
sub GetDistributedTo {
my $dbh = C4::Context->dbh;
my $distributedto;
my $subscriptionid = @_;
- my $query = qq|
- SELECT distributedto
- FROM subscription
- WHERE subscriptionid=?
- |;
+ my $query = "SELECT distributedto FROM subscription WHERE subscriptionid=?";
my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
return ($distributedto) = $sth->fetchrow;
@@ -605,116 +886,111 @@
=back
=cut
-sub Get_Next_Seq {
- my ($val) =@_;
- my ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3);
- $calculated = $val->{numberingmethod};
-# calculate the (expected) value of the next issue received.
- $newlastvalue1 = $val->{lastvalue1};
-# check if we have to increase the new value.
- $newinnerloop1 = $val->{innerloop1}+1;
- $newinnerloop1=0 if ($newinnerloop1 >= $val->{every1});
- $newlastvalue1 += $val->{add1} if ($newinnerloop1<1); # <1 to be true when 0 or empty.
- $newlastvalue1=$val->{setto1} if ($newlastvalue1>$val->{whenmorethan1}); # reset counter if needed.
- $calculated =~ s/\{X\}/$newlastvalue1/g;
-
- $newlastvalue2 = $val->{lastvalue2};
-# check if we have to increase the new value.
- $newinnerloop2 = $val->{innerloop2}+1;
- $newinnerloop2=0 if ($newinnerloop2 >= $val->{every2});
- $newlastvalue2 += $val->{add2} if ($newinnerloop2<1); # <1 to be true when 0 or empty.
- $newlastvalue2=$val->{setto2} if ($newlastvalue2>$val->{whenmorethan2}); # reset counter if needed.
- $calculated =~ s/\{Y\}/$newlastvalue2/g;
-
- $newlastvalue3 = $val->{lastvalue3};
-# check if we have to increase the new value.
- $newinnerloop3 = $val->{innerloop3}+1;
- $newinnerloop3=0 if ($newinnerloop3 >= $val->{every3});
- $newlastvalue3 += $val->{add3} if ($newinnerloop3<1); # <1 to be true when 0 or empty.
- $newlastvalue3=$val->{setto3} if ($newlastvalue3>$val->{whenmorethan3}); # reset counter if needed.
- $calculated =~ s/\{Z\}/$newlastvalue3/g;
- return ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3);
-}
+# sub GetNextSeq {
+# my ($val) =@_;
+# my ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3);
+# $calculated = $val->{numberingmethod};
+# # calculate the (expected) value of the next issue recieved.
+# $newlastvalue1 = $val->{lastvalue1};
+# # check if we have to increase the new value.
+# $newinnerloop1 = $val->{innerloop1}+1;
+# $newinnerloop1=0 if ($newinnerloop1 >= $val->{every1});
+# $newlastvalue1 += $val->{add1} if ($newinnerloop1<1); # <1 to be true when 0 or empty.
+# $newlastvalue1=$val->{setto1} if ($newlastvalue1>$val->{whenmorethan1}); # reset counter if needed.
+# $calculated =~ s/\{X\}/$newlastvalue1/g;
+#
+# $newlastvalue2 = $val->{lastvalue2};
+# # check if we have to increase the new value.
+# $newinnerloop2 = $val->{innerloop2}+1;
+# $newinnerloop2=0 if ($newinnerloop2 >= $val->{every2});
+# $newlastvalue2 += $val->{add2} if ($newinnerloop2<1); # <1 to be true when 0 or empty.
+# $newlastvalue2=$val->{setto2} if ($newlastvalue2>$val->{whenmorethan2}); # reset counter if needed.
+# $calculated =~ s/\{Y\}/$newlastvalue2/g;
+#
+# $newlastvalue3 = $val->{lastvalue3};
+# # check if we have to increase the new value.
+# $newinnerloop3 = $val->{innerloop3}+1;
+# $newinnerloop3=0 if ($newinnerloop3 >= $val->{every3});
+# $newlastvalue3 += $val->{add3} if ($newinnerloop3<1); # <1 to be true when 0 or empty.
+# $newlastvalue3=$val->{setto3} if ($newlastvalue3>$val->{whenmorethan3}); # reset counter if needed.
+# $calculated =~ s/\{Z\}/$newlastvalue3/g;
+# return ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3);
+# }
sub GetNextSeq {
- my ($val) =@_;
- my ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3);
+ my ($val) = @_;
+ my (
+ $calculated, $newlastvalue1, $newlastvalue2, $newlastvalue3,
+ $newinnerloop1, $newinnerloop2, $newinnerloop3
+ );
my $pattern = $val->{numberpattern};
- my @seasons = ('nothing','Winter','Spring','Summer','Autumn');
- my @southern_seasons = ('','Summer','Autumn','Winter','Spring');
+ my @seasons = ( 'nothing', 'Winter', 'Spring', 'Summer', 'Autumn' );
+ my @southern_seasons = ( '', 'Summer', 'Autumn', 'Winter', 'Spring' );
$calculated = $val->{numberingmethod};
$newlastvalue1 = $val->{lastvalue1};
$newlastvalue2 = $val->{lastvalue2};
$newlastvalue3 = $val->{lastvalue3};
- if($newlastvalue3 > 0){ # if x y and z columns are used
- $newlastvalue3 = $newlastvalue3+1;
- if($newlastvalue3 > $val->{whenmorethan3}){
+
+ if ( $newlastvalue3 > 0 ) { # if x y and z columns are used
+ $newlastvalue3 = $newlastvalue3 + 1;
+ if ( $newlastvalue3 > $val->{whenmorethan3} ) {
$newlastvalue3 = $val->{setto3};
$newlastvalue2++;
- if($newlastvalue2 > $val->{whenmorethan2}){
+ if ( $newlastvalue2 > $val->{whenmorethan2} ) {
$newlastvalue1++;
$newlastvalue2 = $val->{setto2};
}
}
$calculated =~ s/\{X\}/$newlastvalue1/g;
- if($pattern == 6){
- if($val->{hemisphere} == 2){
+ if ( $pattern == 6 ) {
+ if ( $val->{hemisphere} == 2 ) {
my $newlastvalue2seq = $southern_seasons[$newlastvalue2];
$calculated =~ s/\{Y\}/$newlastvalue2seq/g;
- } else {
+ }
+ else {
my $newlastvalue2seq = $seasons[$newlastvalue2];
$calculated =~ s/\{Y\}/$newlastvalue2seq/g;
}
- } else {
+ }
+ else {
$calculated =~ s/\{Y\}/$newlastvalue2/g;
}
$calculated =~ s/\{Z\}/$newlastvalue3/g;
}
- if($newlastvalue2 > 0 && $newlastvalue3 < 1){ # if x and y columns are used
- $newlastvalue2 = $newlastvalue2+1;
- if($newlastvalue2 > $val->{whenmorethan2}){
+ if ( $newlastvalue2 > 0 && $newlastvalue3 < 1 )
+ { # if x and y columns are used
+ $newlastvalue2 = $newlastvalue2 + 1;
+ if ( $newlastvalue2 > $val->{whenmorethan2} ) {
$newlastvalue2 = $val->{setto2};
$newlastvalue1++;
}
$calculated =~ s/\{X\}/$newlastvalue1/g;
- if($pattern == 6){
- if($val->{hemisphere} == 2){
+ if ( $pattern == 6 ) {
+ if ( $val->{hemisphere} == 2 ) {
my $newlastvalue2seq = $southern_seasons[$newlastvalue2];
$calculated =~ s/\{Y\}/$newlastvalue2seq/g;
- } else {
+ }
+ else {
my $newlastvalue2seq = $seasons[$newlastvalue2];
$calculated =~ s/\{Y\}/$newlastvalue2seq/g;
}
- } else {
+ }
+ else {
$calculated =~ s/\{Y\}/$newlastvalue2/g;
}
}
- if($newlastvalue1 > 0 && $newlastvalue2 < 1 && $newlastvalue3 < 1){ # if column x only
- $newlastvalue1 = $newlastvalue1+1;
- if($newlastvalue1 > $val->{whenmorethan1}){
+ if ( $newlastvalue1 > 0 && $newlastvalue2 < 1 && $newlastvalue3 < 1 )
+ { # if column x only
+ $newlastvalue1 = $newlastvalue1 + 1;
+ if ( $newlastvalue1 > $val->{whenmorethan1} ) {
$newlastvalue1 = $val->{setto2};
}
$calculated =~ s/\{X\}/$newlastvalue1/g;
}
- return ($calculated,$newlastvalue1,$newlastvalue2,$newlastvalue3);
+ return ( $calculated, $newlastvalue1, $newlastvalue2, $newlastvalue3 );
}
-
-=head2 GetNextDate
-
-=over 4
-
-$resultdate = GetNextDate($planneddate,$subscription)
-
-this function get the date after $planneddate.
-return:
-the date on ISO format.
-
-=back
-
-=cut
-
=head2 GetSeq
=over 4
@@ -728,50 +1004,85 @@
=back
=cut
+
sub GetSeq {
- my ($val) =@_;
+ my ($val) = @_;
+ my $pattern = $val->{numberpattern};
+ my @seasons = ( 'nothing', 'Winter', 'Spring', 'Summer', 'Autumn' );
+ my @southern_seasons = ( '', 'Summer', 'Autumn', 'Winter', 'Spring' );
my $calculated = $val->{numberingmethod};
- my $x=$val->{'lastvalue1'};
+ my $x = $val->{'lastvalue1'};
$calculated =~ s/\{X\}/$x/g;
- my $y=$val->{'lastvalue2'};
- $calculated =~ s/\{Y\}/$y/g;
- my $z=$val->{'lastvalue3'};
+ my $newlastvalue2 = $val->{'lastvalue2'};
+ if ( $pattern == 6 ) {
+ if ( $val->{hemisphere} == 2 ) {
+ my $newlastvalue2seq = $southern_seasons[$newlastvalue2];
+ $calculated =~ s/\{Y\}/$newlastvalue2seq/g;
+ }
+ else {
+ my $newlastvalue2seq = $seasons[$newlastvalue2];
+ $calculated =~ s/\{Y\}/$newlastvalue2seq/g;
+ }
+ }
+ else {
+ $calculated =~ s/\{Y\}/$newlastvalue2/g;
+ }
+ my $z = $val->{'lastvalue3'};
$calculated =~ s/\{Z\}/$z/g;
return $calculated;
}
-=head2 GetSubscriptionExpirationDate
+=head2 GetExpirationDate
-=over 4
-
-$sensddate = GetSubscriptionExpirationDate($subscriptionid)
+$sensddate = GetExpirationDate($subscriptionid)
this function return the expiration date for a subscription given on input args.
return
the enddate
-=back
-
=cut
-sub GetSubscriptionExpirationDate {
+
+sub GetExpirationDate {
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
my $subscription = GetSubscription($subscriptionid);
- my $enddate=$subscription->{startdate};
- # we don't do the same test if the subscription is based on X numbers or on X weeks/months
- if ($subscription->{numberlength}) {
+ my $enddate = $subscription->{startdate};
+
+# we don't do the same test if the subscription is based on X numbers or on X weeks/months
+# warn "SUBSCRIPTIONID :$subscriptionid";
+# use Data::Dumper; warn Dumper($subscription);
+
+ if ( $subscription->{numberlength} ) {
#calculate the date of the last issue.
- for (my $i=1;$i<=$subscription->{numberlength};$i++) {
- $enddate = GetNextDate($enddate,$subscription);
- }
- }
- else {
- my $duration;
- $duration=get_duration($subscription->{monthlength}." months") if ($subscription->{monthlength});
- $duration=get_duration($subscription->{weeklength}." weeks") if ($subscription->{weeklength});
- $enddate = DATE_Add_Duration($subscription->{startdate},$duration) ;
+ my $length = $subscription->{numberlength};
+# warn "ENDDATE ".$enddate;
+ for ( my $i = 1 ; $i <= $length ; $i++ ) {
+ $enddate = GetNextDate( $enddate, $subscription );
+# warn "AFTER ENDDATE ".$enddate;
+ }
+ }
+ elsif ( $subscription->{monthlength} ){
+# warn "dateCHECKRESERV :".$subscription->{startdate};
+ my @date=split (/-/,$subscription->{startdate});
+ my @enddate = Add_Delta_YM($date[0],$date[1],$date[2],0,$subscription->{monthlength});
+ $enddate=sprintf("%04d-%02d-%02d",$enddate[0],$enddate[1],$enddate[2]);
+ } elsif ( $subscription->{weeklength} ){
+ my @date=split (/-/,$subscription->{startdate});
+# warn "dateCHECKRESERV :".$subscription->{startdate};
+#### An other way to do it
+# if ( $subscription->{weeklength} ){
+# my ($weeknb,$year)=Week_of_Year(@startdate);
+# $weeknb += $subscription->{weeklength};
+# my $weeknbcalc= $weeknb % 52;
+# $year += int($weeknb/52);
+# # warn "year : $year weeknb :$weeknb weeknbcalc $weeknbcalc";
+# @endofsubscriptiondate=Monday_of_Week($weeknbcalc,$year);
+# }
+ my @enddate = Add_Delta_Days($date[0],$date[1],$date[2],$subscription->{weeklength}*7);
+ $enddate=sprintf("%04d-%02d-%02d",$enddate[0],$enddate[1],$enddate[2]);
}
+# warn "date de fin :$enddate";
return $enddate;
}
@@ -787,45 +1098,48 @@
=back
=cut
+
sub CountSubscriptionFromBiblionumber {
my ($biblionumber) = @_;
my $dbh = C4::Context->dbh;
- my $query = qq|
- SELECT count(*)
- FROM subscription
- WHERE biblionumber=?
- |;
+ my $query = "SELECT count(*) FROM subscription WHERE biblionumber=?";
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
my $subscriptionsnumber = $sth->fetchrow;
return $subscriptionsnumber;
}
-
=head2 ModSubscriptionHistory
=over 4
-ModSubscriptionHistory($subscriptionid,$histstartdate,$enddate,$receivedlist,$missinglist,$opacnote,$librariannote);
+ModSubscriptionHistory($subscriptionid,$histstartdate,$enddate,$recievedlist,$missinglist,$opacnote,$librariannote);
this function modify the history of a subscription. Put your new values on input arg.
=back
=cut
+
sub ModSubscriptionHistory {
- my ($subscriptionid,$histstartdate,$enddate,$receivedlist,$missinglist,$opacnote,$librariannote)=@_;
- my $dbh=C4::Context->dbh;
- my $query = qq(
- UPDATE subscriptionhistory
- SET histstartdate=?,enddate=?,receivedlist=?,missinglist=?,opacnote=?,librariannote=?
+ my (
+ $subscriptionid, $histstartdate, $enddate, $recievedlist,
+ $missinglist, $opacnote, $librariannote
+ ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "UPDATE subscriptionhistory
+ SET histstartdate=?,enddate=?,recievedlist=?,missinglist=?,opacnote=?,librariannote=?
WHERE subscriptionid=?
- );
+ ";
my $sth = $dbh->prepare($query);
- $receivedlist =~ s/^,//g;
+ $recievedlist =~ s/^,//g;
$missinglist =~ s/^,//g;
$opacnote =~ s/^,//g;
- $sth->execute($histstartdate,$enddate,$receivedlist,$missinglist,$opacnote,$librariannote,$subscriptionid);
+ $sth->execute(
+ $histstartdate, $enddate, $recievedlist, $missinglist,
+ $opacnote, $librariannote, $subscriptionid
+ );
+ return $sth->rows;
}
=head2 ModSerialStatus
@@ -840,75 +1154,92 @@
=back
=cut
+
sub ModSerialStatus {
- my ($serialid,$serialseq, $publisheddate,$planneddate,$status,$notes,$itemnumber)=@_;
+ my ( $serialid, $serialseq, $publisheddate, $planneddate, $status, $notes )
+ = @_;
+ #It is a usual serial
# 1st, get previous status :
my $dbh = C4::Context->dbh;
- my $query = qq|
- SELECT subscriptionid,status
- FROM serial
- WHERE serialid=?
- |;
+ my $query = "SELECT subscriptionid,status FROM serial WHERE serialid=?";
my $sth = $dbh->prepare($query);
$sth->execute($serialid);
- my ($subscriptionid,$oldstatus) = $sth->fetchrow;
+ my ( $subscriptionid, $oldstatus ) = $sth->fetchrow;
+
# change status & update subscriptionhistory
- if ($status eq 6){
- DelIssue($serialseq, $subscriptionid)
- } else {
- my $query = qq(
- UPDATE serial
- SET serialseq=?,publisheddate=?,planneddate=?,status=?,notes=?,itemnumber=?
- WHERE serialid = ?
- );
+ my $val;
+ if ( $status eq 6 ) {
+ DelIssue( $serialseq, $subscriptionid );
+ }
+ else {
+ my $query =
+"UPDATE serial SET serialseq=?,publisheddate=?,planneddate=?,status=?,notes=? WHERE serialid = ?";
$sth = $dbh->prepare($query);
- $sth->execute($serialseq,format_date_in_iso($publisheddate),format_date_in_iso($planneddate),$status,$notes,$itemnumber,$serialid);
- my $query = qq(
- SELECT missinglist,receivedlist
- FROM subscriptionhistory
- WHERE subscriptionid=?
- );
+ $sth->execute( $serialseq, $publisheddate, $planneddate, $status,
+ $notes, $serialid );
+ $query = "SELECT * FROM subscription WHERE subscriptionid = ?";
$sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
- my ($missinglist,$receivedlist) = $sth->fetchrow;
- if ($status == 2 && $oldstatus != 2) {
- $receivedlist .= ",$serialseq";
+ my $val = $sth->fetchrow_hashref;
+ unless ( $val->{manualhistory} ) {
+ $query =
+"SELECT missinglist,recievedlist FROM subscriptionhistory WHERE subscriptionid=?";
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ( $missinglist, $recievedlist ) = $sth->fetchrow;
+ if ( $status eq 2 ) {
+
+# warn "receivedlist : $recievedlist serialseq :$serialseq, ".index("$recievedlist","$serialseq");
+ $recievedlist .= ",$serialseq"
+ unless ( index( "$recievedlist", "$serialseq" ) >= 0 );
+ }
+
+# warn "missinglist : $missinglist serialseq :$serialseq, ".index("$missinglist","$serialseq");
+ $missinglist .= ",$serialseq"
+ if ( $status eq 4
+ and not index( "$missinglist", "$serialseq" ) >= 0 );
+ $missinglist .= ",not issued $serialseq"
+ if ( $status eq 5
+ and index( "$missinglist", "$serialseq" ) >= 0 );
+ $query =
+"UPDATE subscriptionhistory SET recievedlist=?, missinglist=? WHERE subscriptionid=?";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $recievedlist, $missinglist, $subscriptionid );
}
- $missinglist .= ",$serialseq" if ($status eq 4) ;
- $missinglist .= ",not issued $serialseq" if ($status eq 5);
- my $query = qq(
- UPDATE subscriptionhistory
- SET receivedlist=?, missinglist=?
- WHERE subscriptionid=?
- );
- $sth=$dbh->prepare($query);
- $sth->execute($receivedlist,$missinglist,$subscriptionid);
}
+
# create new waited entry if needed (ie : was a "waited" and has changed)
- if ($oldstatus eq 1 && $status ne 1) {
- my $query = qq(
- SELECT *
- FROM subscription
- WHERE subscriptionid = ?
- );
+ if ( $oldstatus eq 1 && $status ne 1 ) {
+ my $query = "SELECT * FROM subscription WHERE subscriptionid = ?";
$sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
my $val = $sth->fetchrow_hashref;
+
# next issue number
- my ($newserialseq,$newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3) = GetNextSeq($val);
+ my (
+ $newserialseq, $newlastvalue1, $newlastvalue2, $newlastvalue3,
+ $newinnerloop1, $newinnerloop2, $newinnerloop3
+ ) = GetNextSeq($val);
+
# next date (calculated from actual date & frequency parameters)
- my $nextplanneddate = GetNextDate($planneddate,$val);
- my $nextpublisheddate = GetNextDate($publisheddate,$val);
- NewIssue($newserialseq, $subscriptionid, $val->{'biblionumber'}, 1, $nextpublisheddate,$nextplanneddate,0);
- my $query = qq|
- UPDATE subscription
- SET lastvalue1=?, lastvalue2=?, lastvalue3=?,
- innerloop1=?, innerloop2=?, innerloop3=?
- WHERE subscriptionid = ?
- |;
+# warn "publisheddate :$publisheddate ";
+ my $nextpublisheddate = GetNextDate( $publisheddate, $val );
+ NewIssue( $newserialseq, $subscriptionid, $val->{'biblionumber'},
+ 1, $nextpublisheddate, $nextpublisheddate );
+ $query =
+"UPDATE subscription SET lastvalue1=?, lastvalue2=?, lastvalue3=?, innerloop1=?, innerloop2=?, innerloop3=?
+ WHERE subscriptionid = ?";
$sth = $dbh->prepare($query);
- $sth->execute($newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3,$subscriptionid);
+ $sth->execute(
+ $newlastvalue1, $newlastvalue2, $newlastvalue3, $newinnerloop1,
+ $newinnerloop2, $newinnerloop3, $subscriptionid
+ );
+
+# check if an alert must be sent... (= a letter is defined & status became "arrived"
+ if ( $val->{letter} && $status eq 2 && $oldstatus ne 2 ) {
+ SendAlerts( 'issue', $val->{subscriptionid}, $val->{letter} );
+ }
}
}
@@ -921,40 +1252,61 @@
=back
=cut
+
sub ModSubscription {
- my ($auser,$aqbooksellerid,$cost,$aqbudgetid,$startdate,
- $periodicity,$dow,$numberlength,$weeklength,$monthlength,
- $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,$innerloop1,
- $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,$innerloop2,
- $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,$innerloop3,
- $numberingmethod, $status, $biblionumber, $notes, $letter, $subscriptionid,$irregularity,$hemisphere,$callnumber,$numberpattern,$publisheddate)= @_;
- my $dbh = C4::Context->dbh;
- my $query = qq|
- UPDATE subscription
- SET librarian=?, aqbooksellerid=?,cost=?,aqbudgetid=?,startdate=?,
- periodicity=?,dow=?,numberlength=?,weeklength=?,monthlength=?,
+ my (
+ $auser, $branchcode, $aqbooksellerid, $cost,
+ $aqbudgetid, $startdate, $periodicity, $firstacquidate,
+ $dow, $irregularity, $numberpattern, $numberlength,
+ $weeklength, $monthlength, $add1, $every1,
+ $whenmorethan1, $setto1, $lastvalue1, $innerloop1,
+ $add2, $every2, $whenmorethan2, $setto2,
+ $lastvalue2, $innerloop2, $add3, $every3,
+ $whenmorethan3, $setto3, $lastvalue3, $innerloop3,
+ $numberingmethod, $status, $biblionumber, $callnumber,
+ $notes, $letter, $hemisphere, $manualhistory,
+ $internalnotes,
+ $subscriptionid
+ ) = @_;
+# warn $irregularity;
+ my $dbh = C4::Context->dbh;
+ my $query = "UPDATE subscription
+ SET librarian=?, branchcode=?,aqbooksellerid=?,cost=?,aqbudgetid=?,startdate=?,
+ periodicity=?,firstacquidate=?,dow=?,irregularity=?, numberpattern=?, numberlength=?,weeklength=?,monthlength=?,
add1=?,every1=?,whenmorethan1=?,setto1=?,lastvalue1=?,innerloop1=?,
add2=?,every2=?,whenmorethan2=?,setto2=?,lastvalue2=?,innerloop2=?,
add3=?,every3=?,whenmorethan3=?,setto3=?,lastvalue3=?,innerloop3=?,
- numberingmethod=?, status=?, biblionumber=?, notes=?, letter=?,irregularity=?,hemisphere=?,callnumber=?,numberpattern=? ,publisheddate=?
- WHERE subscriptionid = ?
- |;
- my $sth=$dbh->prepare($query);
- $sth->execute($auser,$aqbooksellerid,$cost,$aqbudgetid,$startdate,
- $periodicity,$dow,$numberlength,$weeklength,$monthlength,
- $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,$innerloop1,
- $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,$innerloop2,
- $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,$innerloop3,
- $numberingmethod, $status, $biblionumber, $notes, $letter, $irregularity,$hemisphere,$callnumber,$numberpattern,$publisheddate,$subscriptionid);
+ numberingmethod=?, status=?, biblionumber=?, callnumber=?, notes=?, letter=?, hemisphere=?,manualhistory=?,internalnotes=?
+ WHERE subscriptionid = ?";
+# warn "query :".$query;
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $auser, $branchcode, $aqbooksellerid, $cost,
+ $aqbudgetid, $startdate, $periodicity, $firstacquidate,
+ $dow, "$irregularity", $numberpattern, $numberlength,
+ $weeklength, $monthlength, $add1, $every1,
+ $whenmorethan1, $setto1, $lastvalue1, $innerloop1,
+ $add2, $every2, $whenmorethan2, $setto2,
+ $lastvalue2, $innerloop2, $add3, $every3,
+ $whenmorethan3, $setto3, $lastvalue3, $innerloop3,
+ $numberingmethod, $status, $biblionumber, $callnumber,
+ $notes, $letter, $hemisphere, ($manualhistory?$manualhistory:0),
+ $internalnotes,
+ $subscriptionid
+ );
+ my $rows=$sth->rows;
$sth->finish;
-}
+ &logaction(C4::Context->userenv->{'number'},"SERIAL","MODIFY",$subscriptionid,"")
+ if C4::Context->preference("SubscriptionLog");
+ return $rows;
+}
=head2 NewSubscription
=over 4
-$subscriptionid = &NewSubscription($auser,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
+$subscriptionid = &NewSubscription($auser,branchcode,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
$startdate,$periodicity,$dow,$numberlength,$weeklength,$monthlength,
$add1,$every1,$whenmorethan1,$setto1,$lastvalue1,$innerloop1,
$add2,$every2,$whenmorethan2,$setto2,$lastvalue2,$innerloop2,
@@ -969,54 +1321,74 @@
=back
=cut
-sub NewSubscription {
- my ($auser,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
- $startdate,$periodicity,$dow,$numberlength,$weeklength,$monthlength,
- $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,
- $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,
- $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,
- $numberingmethod, $status, $notes, $letter,$irregularity,$hemisphere,$callnumber,$numberpattern,$publisheddate) = @_;
+sub NewSubscription {
+ my (
+ $auser, $branchcode, $aqbooksellerid, $cost,
+ $aqbudgetid, $biblionumber, $startdate, $periodicity,
+ $dow, $numberlength, $weeklength, $monthlength,
+ $add1, $every1, $whenmorethan1, $setto1,
+ $lastvalue1, $innerloop1, $add2, $every2,
+ $whenmorethan2, $setto2, $lastvalue2, $innerloop2,
+ $add3, $every3, $whenmorethan3, $setto3,
+ $lastvalue3, $innerloop3, $numberingmethod, $status,
+ $notes, $letter, $firstacquidate, $irregularity,
+ $numberpattern, $callnumber, $hemisphere, $manualhistory,
+ $internalnotes
+ ) = @_;
my $dbh = C4::Context->dbh;
-#save subscription (insert into database)
+
+ #save subscription (insert into database)
my $query = qq|
INSERT INTO subscription
- (librarian,aqbooksellerid,cost,aqbudgetid,biblionumber,
+ (librarian,branchcode,aqbooksellerid,cost,aqbudgetid,biblionumber,
startdate,periodicity,dow,numberlength,weeklength,monthlength,
- add1,every1,whenmorethan1,setto1,lastvalue1,
- add2,every2,whenmorethan2,setto2,lastvalue2,
- add3,every3,whenmorethan3,setto3,lastvalue3,
- numberingmethod, status, notes, letter,irregularity,hemisphere,callnumber,numberpattern,publisheddate)
- VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+ add1,every1,whenmorethan1,setto1,lastvalue1,innerloop1,
+ add2,every2,whenmorethan2,setto2,lastvalue2,innerloop2,
+ add3,every3,whenmorethan3,setto3,lastvalue3,innerloop3,
+ numberingmethod, status, notes, letter,firstacquidate,irregularity,
+ numberpattern, callnumber, hemisphere,manualhistory,internalnotes)
+ VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|;
- my $sth=$dbh->prepare($query);
+ my $sth = $dbh->prepare($query);
$sth->execute(
- $auser,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
- format_date_in_iso($startdate),$periodicity,$dow,$numberlength,$weeklength,$monthlength,
- $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,
- $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,
- $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,
- $numberingmethod, $status, $notes, $letter,$irregularity,$hemisphere,$callnumber,$numberpattern,format_date_in_iso($publisheddate));
-
+ $auser, $branchcode,
+ $aqbooksellerid, $cost,
+ $aqbudgetid, $biblionumber,
+ format_date_in_iso($startdate), $periodicity,
+ $dow, $numberlength,
+ $weeklength, $monthlength,
+ $add1, $every1,
+ $whenmorethan1, $setto1,
+ $lastvalue1, $innerloop1,
+ $add2, $every2,
+ $whenmorethan2, $setto2,
+ $lastvalue2, $innerloop2,
+ $add3, $every3,
+ $whenmorethan3, $setto3,
+ $lastvalue3, $innerloop3,
+ $numberingmethod, "$status",
+ $notes, $letter,
+ $firstacquidate, $irregularity,
+ $numberpattern, $callnumber,
+ $hemisphere, $manualhistory,
+ $internalnotes
+ );
-#then create the 1st waited number
+ #then create the 1st waited number
my $subscriptionid = $dbh->{'mysql_insertid'};
- my $enddate = GetSubscriptionExpirationDate($subscriptionid);
- my $query = qq(
+ $query = qq(
INSERT INTO subscriptionhistory
- (biblionumber, subscriptionid, histstartdate, enddate, missinglist, receivedlist, opacnote, librariannote)
+ (biblionumber, subscriptionid, histstartdate, enddate, missinglist, recievedlist, opacnote, librariannote)
VALUES (?,?,?,?,?,?,?,?)
);
$sth = $dbh->prepare($query);
- $sth->execute($biblionumber, $subscriptionid, format_date_in_iso($startdate), format_date_in_iso($enddate), "", "", "", $notes);
-## User may have subscriptionid stored in MARC so check and fill it
-my $record=XMLgetbiblio($dbh,$biblionumber);
-$record=XML_xml2hash_onerecord($record);
-XML_writeline( $record, "subscriptionid", $subscriptionid,"biblios" );
-my $frameworkcode=MARCfind_frameworkcode($dbh,$biblionumber);
-NEWmodbiblio($dbh,$biblionumber,$record,$frameworkcode);
-# reread subscription to get a hash (for calculation of the 1st issue number)
- my $query = qq(
+ $sth->execute( $biblionumber, $subscriptionid,
+ format_date_in_iso($startdate),
+ 0, "", "", "", "$notes" );
+
+ # reread subscription to get a hash (for calculation of the 1st issue number)
+ $query = qq(
SELECT *
FROM subscription
WHERE subscriptionid = ?
@@ -1025,20 +1397,26 @@
$sth->execute($subscriptionid);
my $val = $sth->fetchrow_hashref;
-# calculate issue number
+ # calculate issue number
my $serialseq = GetSeq($val);
- my $query = qq|
+ $query = qq|
INSERT INTO serial
- (serialseq,subscriptionid,biblionumber,status, planneddate,publisheddate)
+ (serialseq,subscriptionid,biblionumber,status, planneddate, publisheddate)
VALUES (?,?,?,?,?,?)
|;
-
$sth = $dbh->prepare($query);
- $sth->execute($serialseq, $subscriptionid, $val->{'biblionumber'}, 1, format_date_in_iso($startdate),format_date_in_iso($publisheddate));
+ $sth->execute(
+ "$serialseq", $subscriptionid, $biblionumber, 1,
+ format_date_in_iso($startdate),
+ format_date_in_iso($startdate)
+ );
+
+ &logaction(C4::Context->userenv->{'number'},"SERIAL","ADD",$subscriptionid,"")
+ if C4::Context->preference("SubscriptionLog");
+
return $subscriptionid;
}
-
=head2 ReNewSubscription
=over 4
@@ -1050,24 +1428,44 @@
=back
=cut
+
sub ReNewSubscription {
- my ($subscriptionid,$user,$startdate,$numberlength,$weeklength,$monthlength,$note) = @_;
+ my ( $subscriptionid, $user, $startdate, $numberlength, $weeklength,
+ $monthlength, $note )
+ = @_;
my $dbh = C4::Context->dbh;
my $subscription = GetSubscription($subscriptionid);
- my $record=XMLgetbiblio($dbh,$subscription->{biblionumber});
- $record=XML_xml2hash_onerecord($record);
- my $biblio = XMLmarc2koha_onerecord($dbh,$record,"biblios");
- NewSuggestion($user,$subscription->{bibliotitle},$biblio->{author},$biblio->{publishercode},$biblio->{note},'','','','','',$subscription->{biblionumber});
- # renew subscription
my $query = qq|
+ SELECT *
+ FROM biblio,biblioitems
+ WHERE biblio.biblionumber=biblioitems.biblionumber
+ AND biblio.biblionumber=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $subscription->{biblionumber} );
+ my $biblio = $sth->fetchrow_hashref;
+ NewSuggestion(
+ $user, $subscription->{bibliotitle},
+ $biblio->{author}, $biblio->{publishercode},
+ $biblio->{note}, '',
+ '', '',
+ '', '',
+ $subscription->{biblionumber}
+ );
+
+ # renew subscription
+ $query = qq|
UPDATE subscription
SET startdate=?,numberlength=?,weeklength=?,monthlength=?
WHERE subscriptionid=?
|;
-my $sth=$dbh->prepare($query);
- $sth->execute(format_date_in_iso($startdate),$numberlength,$weeklength,$monthlength, $subscriptionid);
-}
+ $sth = $dbh->prepare($query);
+ $sth->execute( format_date_in_iso($startdate),
+ $numberlength, $weeklength, $monthlength, $subscriptionid );
+ &logaction(C4::Context->userenv->{'number'},"SERIAL","RENEW",$subscriptionid,"")
+ if C4::Context->preference("SubscriptionLog");
+}
=head2 NewIssue
@@ -1076,107 +1474,256 @@
NewIssue($serialseq,$subscriptionid,$biblionumber,$status, $publisheddate, $planneddate)
Create a new issue stored on the database.
-Note : we have to update the receivedlist and missinglist on subscriptionhistory for this subscription.
+Note : we have to update the recievedlist and missinglist on subscriptionhistory for this subscription.
=back
=cut
+
sub NewIssue {
- my ($serialseq,$subscriptionid,$biblionumber,$status, $publisheddate, $planneddate,$itemnumber) = @_;
+ my ( $serialseq, $subscriptionid, $biblionumber, $status, $publisheddate,
+ $planneddate, $notes )
+ = @_;
+ ### FIXME biblionumber CAN be provided by subscriptionid. So Do we STILL NEED IT ?
+
my $dbh = C4::Context->dbh;
my $query = qq|
INSERT INTO serial
- (serialseq,subscriptionid,biblionumber,status,publisheddate,planneddate,itemnumber)
+ (serialseq,subscriptionid,biblionumber,status,publisheddate,planneddate,notes)
VALUES (?,?,?,?,?,?,?)
|;
my $sth = $dbh->prepare($query);
- $sth->execute($serialseq,$subscriptionid,$biblionumber,$status,format_date_in_iso($publisheddate), format_date_in_iso($planneddate),$itemnumber);
-
- my $query = qq|
- SELECT missinglist,receivedlist
+ $sth->execute( $serialseq, $subscriptionid, $biblionumber, $status,
+ $publisheddate, $planneddate,$notes );
+ my $serialid=$dbh->{'mysql_insertid'};
+ $query = qq|
+ SELECT missinglist,recievedlist
FROM subscriptionhistory
WHERE subscriptionid=?
|;
$sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
- my ($missinglist,$receivedlist) = $sth->fetchrow;
- if ($status eq 2) {
- $receivedlist .= ",$serialseq";
+ my ( $missinglist, $recievedlist ) = $sth->fetchrow;
+
+ if ( $status eq 2 ) {
+ ### TODO Add a feature that improves recognition and description.
+ ### As such count (serialseq) i.e. : N°18,2(N°19),N°20
+ ### Would use substr and index But be careful to previous presence of ()
+ $recievedlist .= ",$serialseq" unless (index($recievedlist,$serialseq)>0);
}
- if ($status eq 4) {
- $missinglist .= ",$serialseq";
+ if ( $status eq 4 ) {
+ $missinglist .= ",$serialseq" unless (index($missinglist,$serialseq)>0);
}
- my $query = qq|
+ $query = qq|
UPDATE subscriptionhistory
- SET receivedlist=?, missinglist=?
+ SET recievedlist=?, missinglist=?
WHERE subscriptionid=?
|;
- $sth=$dbh->prepare($query);
- $sth->execute($receivedlist,$missinglist,$subscriptionid);
+ $sth = $dbh->prepare($query);
+ $sth->execute( $recievedlist, $missinglist, $subscriptionid );
+ return $serialid;
}
-=head2 serialchangestatus
+=head2 ItemizeSerials
=over 4
-serialchangestatus($serialid,$serialseq,$planneddate,$status,$notes)
-
-Change the status of a serial issue.
-Note: this was the older subroutine
+ItemizeSerials($serialid, $info);
+$info is a hashref containing barcode branch, itemcallnumber, status, location
+$serialid the serialid
+return :
+1 if the itemize is a succes.
+0 and @error else. @error containts the list of errors found.
=back
=cut
-sub serialchangestatus {
- my ($serialid,$serialseq,$planneddate,$status,$notes)=@_;
- # 1st, get previous status : if we change from "waited" to something else, then we will have to create a new "waited" entry
+
+sub ItemizeSerials {
+ my ( $serialid, $info ) = @_;
+ my $now = POSIX::strftime( "%Y-%m-%d",localtime );
+
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("select subscriptionid,status from serial where serialid=?");
+ my $query = qq|
+ SELECT *
+ FROM serial
+ WHERE serialid=?
+ |;
+ my $sth = $dbh->prepare($query);
$sth->execute($serialid);
- my ($subscriptionid,$oldstatus) = $sth->fetchrow;
- # change status & update subscriptionhistory
- if ($status eq 6){
- delissue($serialseq, $subscriptionid)
- }else{
- $sth = $dbh->prepare("update serial set serialseq=?,planneddate=?,status=?,notes=? where serialid = ?");
- $sth->execute($serialseq,format_date_in_iso($planneddate),$status,$notes,$serialid);
-
- $sth = $dbh->prepare("select missinglist,receivedlist from subscriptionhistory where subscriptionid=?");
- $sth->execute($subscriptionid);
- my ($missinglist,$receivedlist) = $sth->fetchrow;
- if ($status eq 2) {
- $receivedlist .= "| $serialseq";
- $receivedlist =~ s/^\| //g;
+ my $data = $sth->fetchrow_hashref;
+ if ( C4::Context->preference("RoutingSerials") ) {
+
+ # check for existing biblioitem relating to serial issue
+ my ( $count, @results ) =
+ GetBiblioItemByBiblioNumber( $data->{'biblionumber'} );
+ my $bibitemno = 0;
+ for ( my $i = 0 ; $i < $count ; $i++ ) {
+ if ( $results[$i]->{'volumeddesc'} eq $data->{'serialseq'} . ' ('
+ . $data->{'planneddate'}
+ . ')' )
+ {
+ $bibitemno = $results[$i]->{'biblioitemnumber'};
+ last;
}
- $missinglist .= "| $serialseq" if ($status eq 4) ;
- $missinglist .= "| not issued $serialseq" if ($status eq 5);
- $missinglist =~ s/^\| //g;
- $sth=$dbh->prepare("update subscriptionhistory set receivedlist=?, missinglist=? where subscriptionid=?");
- $sth->execute($receivedlist,$missinglist,$subscriptionid);
}
- # create new waited entry if needed (ie : was a "waited" and has changed)
- if ($oldstatus eq 1 && $status ne 1) {
- $sth = $dbh->prepare("select * from subscription where subscriptionid = ? ");
- $sth->execute($subscriptionid);
- my $val = $sth->fetchrow_hashref;
- # next issue number
- my ($newserialseq,$newlastvalue1,$newlastvalue2,$newlastvalue3) = New_Get_Next_Seq($val);
- my $nextplanneddate = GetNextDate($planneddate,$val);
- NewIssue($newserialseq, $subscriptionid, $val->{'biblionumber'}, 1, $nextplanneddate);
- $sth = $dbh->prepare("update subscription set lastvalue1=?, lastvalue2=?,lastvalue3=? where subscriptionid = ?");
- $sth->execute($newlastvalue1,$newlastvalue2,$newlastvalue3,$subscriptionid);
- }
- # check if an alert must be sent... (= a letter is defined & status became "arrived"
- $sth = $dbh->prepare("select * from subscription where subscriptionid = ? ");
- $sth->execute($subscriptionid);
- my $subscription = $sth->fetchrow_hashref;
- if ($subscription->{letter} && $status eq 2) {
- sendalerts('issue',$subscription->{subscriptionid},$subscription->{letter});
- }
-}
-
+ if ( $bibitemno == 0 ) {
+ # warn "need to add new biblioitem so copy last one and make minor changes";
+ my $sth =
+ $dbh->prepare(
+"SELECT * FROM biblioitems WHERE biblionumber = ? ORDER BY biblioitemnumber DESC"
+ );
+ $sth->execute( $data->{'biblionumber'} );
+ my $biblioitem = $sth->fetchrow_hashref;
+ $biblioitem->{'volumedate'} =
+ format_date_in_iso( $data->{planneddate} );
+ $biblioitem->{'volumeddesc'} =
+ $data->{serialseq} . ' ('
+ . format_date( $data->{'planneddate'} ) . ')';
+ $biblioitem->{'dewey'} = $info->{itemcallnumber};
+
+ #FIXME HDL : I don't understand why you need to call newbiblioitem, as the biblioitem should already be somewhere.
+ # so I comment it, we can speak of it when you want
+ # newbiblioitems has been removed from Biblio.pm, as it has a deprecated API now
+# if ( $info->{barcode} )
+# { # only make biblioitem if we are going to make item also
+# $bibitemno = newbiblioitem($biblioitem);
+# }
+ }
+ }
+ my $fwk = MARCfind_frameworkcode( $data->{'biblionumber'} );
+ if ( $info->{barcode} ) {
+ my @errors;
+ my $exists = itemdata( $info->{'barcode'} );
+ push @errors, "barcode_not_unique" if ($exists);
+ unless ($exists) {
+ my $marcrecord = MARC::Record->new();
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.barcode", $fwk );
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{barcode} );
+ $marcrecord->insert_fields_ordered($newField);
+ if ( $info->{branch} ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.homebranch",
+ $fwk );
+
+ #warn "items.homebranch : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{branch} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{branch} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.holdingbranch",
+ $fwk );
+
+ #warn "items.holdingbranch : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{branch} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{branch} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ if ( $info->{itemcallnumber} ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.itemcallnumber",
+ $fwk );
+
+ #warn "items.itemcallnumber : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{itemcallnumber} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{itemcallnumber} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ if ( $info->{notes} ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.itemnotes", $fwk );
+
+ # warn "items.itemnotes : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{notes} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{notes} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ if ( $info->{location} ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.location", $fwk );
+
+ # warn "items.location : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{location} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{location} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ if ( $info->{status} ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.notforloan",
+ $fwk );
+
+ # warn "items.notforloan : $tag , $subfield";
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $info->{status} );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '',
+ "$subfield" => $info->{status} );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ if ( C4::Context->preference("RoutingSerials") ) {
+ my ( $tag, $subfield ) =
+ MARCfind_marc_from_kohafield( $dbh, "items.dateaccessioned",
+ $fwk );
+ if ( $marcrecord->field($tag) ) {
+ $marcrecord->field($tag)
+ ->add_subfields( "$subfield" => $now );
+ }
+ else {
+ my $newField =
+ MARC::Field->new( "$tag", '', '', "$subfield" => $now );
+ $marcrecord->insert_fields_ordered($newField);
+ }
+ }
+ AddItem( $marcrecord, $data->{'biblionumber'} );
+ return 1;
+ }
+ return ( 0, @errors );
+ }
+}
=head2 HasSubscriptionExpired
@@ -1192,27 +1739,12 @@
=back
=cut
+
sub HasSubscriptionExpired {
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
my $subscription = GetSubscription($subscriptionid);
- # we don't do the same test if the subscription is based on X numbers or on X weeks/months
- if ($subscription->{numberlength} ) {
- my $query = qq|
- SELECT count(*)
- FROM serial
- WHERE subscriptionid=? AND planneddate>=?
- |;
- my $sth = $dbh->prepare($query);
- $sth->execute($subscriptionid,$subscription->{startdate});
- my $res = $sth->fetchrow;
- if ($subscription->{numberlength}>=$res) {
- return 0;
- } else {
- return 1;
- }
- } else {
- #a little bit more tricky if based on X weeks/months : search if the latest issue waited is not after subscription startdate + duration
+ my $expirationdate = GetExpirationDate($subscriptionid);
my $query = qq|
SELECT max(planneddate)
FROM serial
@@ -1220,16 +1752,13 @@
|;
my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
- my $res = $sth->fetchrow;
- my $endofsubscriptiondate;
- my $duration;
- $duration=get_duration($subscription->{monthlength}." months") if ($subscription->{monthlength});
- $duration=get_duration($subscription->{weeklength}." weeks") if ($subscription->{weeklength});
-
- $endofsubscriptiondate = DATE_Add_Duration($subscription->{startdate},$duration) ;
- return 1 if ($res ge $endofsubscriptiondate);
+ my ($res) = $sth->fetchrow ;
+ my @res=split (/-/,$res);
+ my @endofsubscriptiondate=split(/-/,$expirationdate);
+ return 1 if ( (@endofsubscriptiondate && Delta_Days($res[0],$res[1],$res[2],
+ $endofsubscriptiondate[0],$endofsubscriptiondate[1],$endofsubscriptiondate[2]) <= 0)
+ || (!$res));
return 0;
- }
}
=head2 SetDistributedto
@@ -1242,8 +1771,9 @@
=back
=cut
+
sub SetDistributedto {
- my ($distributedto,$subscriptionid) = @_;
+ my ( $distributedto, $subscriptionid ) = @_;
my $dbh = C4::Context->dbh;
my $query = qq|
UPDATE subscription
@@ -1251,7 +1781,7 @@
WHERE subscriptionid=?
|;
my $sth = $dbh->prepare($query);
- $sth->execute($distributedto,$subscriptionid);
+ $sth->execute( $distributedto, $subscriptionid );
}
=head2 DelSubscription
@@ -1264,19 +1794,18 @@
=back
=cut
+
sub DelSubscription {
- my ($subscriptionid,$biblionumber) = @_;
+ my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
-## User may have subscriptionid stored in MARC so check and remove it
-my $record=XMLgetbibliohash($dbh,$biblionumber);
-XML_writeline( $record, "subscriptionid", "","biblios" );
-my $frameworkcode=MARCfind_frameworkcode($dbh,$biblionumber);
-NEWmodbiblio($dbh,$biblionumber,$record,$frameworkcode);
- $subscriptionid=$dbh->quote($subscriptionid);
+ $subscriptionid = $dbh->quote($subscriptionid);
$dbh->do("DELETE FROM subscription WHERE subscriptionid=$subscriptionid");
- $dbh->do("DELETE FROM subscriptionhistory WHERE subscriptionid=$subscriptionid");
+ $dbh->do(
+ "DELETE FROM subscriptionhistory WHERE subscriptionid=$subscriptionid");
$dbh->do("DELETE FROM serial WHERE subscriptionid=$subscriptionid");
+ &logaction(C4::Context->userenv->{'number'},"SERIAL","DELETE",$subscriptionid,"")
+ if C4::Context->preference("SubscriptionLog");
}
=head2 DelIssue
@@ -1289,25 +1818,52 @@
=back
=cut
+
sub DelIssue {
- my ($serialseq,$subscriptionid) = @_;
+ my ( $serialseq, $subscriptionid ) = @_;
my $dbh = C4::Context->dbh;
my $query = qq|
DELETE FROM serial
WHERE serialseq= ?
AND subscriptionid= ?
|;
+ my $mainsth = $dbh->prepare($query);
+ $mainsth->execute( $serialseq, $subscriptionid );
+
+ #Delete element from subscription history
+ $query = "SELECT * FROM subscription WHERE subscriptionid = ?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $val = $sth->fetchrow_hashref;
+ unless ( $val->{manualhistory} ) {
+ my $query = qq|
+ SELECT * FROM subscriptionhistory
+ WHERE subscriptionid= ?
+ |;
my $sth = $dbh->prepare($query);
- $sth->execute($serialseq,$subscriptionid);
+ $sth->execute($subscriptionid);
+ my $data = $sth->fetchrow_hashref;
+ $data->{'missinglist'} =~ s/$serialseq//;
+ $data->{'recievedlist'} =~ s/$serialseq//;
+ my $strsth = "UPDATE subscriptionhistory SET "
+ . join( ",",
+ map { join( "=", $_, $dbh->quote( $data->{$_} ) ) } keys %$data )
+ . " WHERE subscriptionid=?";
+ $sth = $dbh->prepare($strsth);
+ $sth->execute($subscriptionid);
+ }
+ ### TODO Add itemdeletion. Should be in a pref ?
+
+ return $mainsth->rows;
}
-=head2 GetMissingIssues
+=head2 GetLateOrMissingIssues
=over 4
-($count, at issuelist) = &GetMissingIssues($supplierid,$serialid)
+($count, at issuelist) = &GetLateMissingIssues($supplierid,$serialid)
-this function select missing issues on database - where serial.status = 4
+this function select missing issues on database - where serial.status = 4 or serial.status=3 or planneddate<now
return :
a count of the number of missing issues
@@ -1317,47 +1873,86 @@
=back
=cut
-sub GetMissingIssues {
- my ($supplierid,$serialid) = @_;
+
+sub GetLateOrMissingIssues {
+ my ( $supplierid, $serialid,$order ) = @_;
my $dbh = C4::Context->dbh;
my $sth;
- my $byserial='';
- if($serialid) {
- $byserial = "and serialid = ".$serialid;
+ my $byserial = '';
+ if ($serialid) {
+ $byserial = "and serialid = " . $serialid;
}
- if ($supplierid) {
- $sth = $dbh->prepare("SELECT serialid,aqbooksellerid,name,title,planneddate,serialseq,serial.subscriptionid,claimdate
- FROM subscription, serial, biblio
- LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
- WHERE subscription.subscriptionid = serial.subscriptionid AND
- serial.STATUS = 4 and
- subscription.aqbooksellerid=$supplierid and
- biblio.biblionumber = subscription.biblionumber ".$byserial." order by title
- ");
+ if ($order){
+ $order.=", title";
} else {
- $sth = $dbh->prepare("SELECT serialid,aqbooksellerid,name,title,planneddate,serialseq,serial.subscriptionid,claimdate
- FROM subscription, serial, biblio
- LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
- WHERE subscription.subscriptionid = serial.subscriptionid AND
- serial.STATUS =4 and
- biblio.biblionumber = subscription.biblionumber ".$byserial." order by title
- ");
+ $order="title";
+ }
+ if ($supplierid) {
+ $sth = $dbh->prepare(
+"SELECT
+ serialid,
+ aqbooksellerid,
+ name,
+ biblio.title,
+ planneddate,
+ serialseq,
+ serial.status,
+ serial.subscriptionid,
+ claimdate
+FROM serial
+LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
+LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
+LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+WHERE subscription.subscriptionid = serial.subscriptionid
+AND (serial.STATUS = 4 OR ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3))
+AND subscription.aqbooksellerid=$supplierid
+$byserial
+ORDER BY $order"
+ );
+ }
+ else {
+ $sth = $dbh->prepare(
+"SELECT
+ serialid,
+ aqbooksellerid,
+ name,
+ biblio.title,
+ planneddate,
+ serialseq,
+ serial.status,
+ serial.subscriptionid,
+ claimdate
+FROM serial
+LEFT JOIN subscription
+ON serial.subscriptionid=subscription.subscriptionid
+LEFT JOIN biblio
+ON serial.biblionumber=biblio.biblionumber
+LEFT JOIN aqbooksellers
+ON subscription.aqbooksellerid = aqbooksellers.id
+WHERE
+ subscription.subscriptionid = serial.subscriptionid
+AND (serial.STATUS = 4 OR ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3))
+AND biblio.biblionumber = subscription.biblionumber
+$byserial
+ORDER BY $order"
+ );
}
$sth->execute;
my @issuelist;
my $last_title;
- my $odd=0;
- my $count=0;
- while (my $line = $sth->fetchrow_hashref) {
+ my $odd = 0;
+ my $count = 0;
+ while ( my $line = $sth->fetchrow_hashref ) {
$odd++ unless $line->{title} eq $last_title;
- $last_title = $line->{title} if ($line->{title});
- $line->{planneddate} = format_date($line->{planneddate});
- $line->{claimdate} = format_date($line->{claimdate});
- $line->{'odd'} = 1 if $odd %2 ;
+ $last_title = $line->{title} if ( $line->{title} );
+ $line->{planneddate} = format_date( $line->{planneddate} );
+ $line->{claimdate} = format_date( $line->{claimdate} );
+ $line->{"status".$line->{status}} = 1;
+ $line->{'odd'} = 1 if $odd % 2;
$count++;
- push @issuelist,$line;
+ push @issuelist, $line;
}
- return $count, at issuelist;
+ return $count, @issuelist;
}
=head2 removeMissingIssue
@@ -1369,30 +1964,37 @@
this function removes an issue from being part of the missing string in
subscriptionlist.missinglist column
-called when a missing issue is found from the statecollection.pl file
+called when a missing issue is found from the serials-recieve.pl file
=back
=cut
+
sub removeMissingIssue {
- my ($sequence,$subscriptionid) = @_;
+ my ( $sequence, $subscriptionid ) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT * FROM subscriptionhistory WHERE subscriptionid = ?");
+ my $sth =
+ $dbh->prepare(
+ "SELECT * FROM subscriptionhistory WHERE subscriptionid = ?");
$sth->execute($subscriptionid);
my $data = $sth->fetchrow_hashref;
my $missinglist = $data->{'missinglist'};
my $missinglistbefore = $missinglist;
+
# warn $missinglist." before";
$missinglist =~ s/($sequence)//;
+
# warn $missinglist." after";
- if($missinglist ne $missinglistbefore){
+ if ( $missinglist ne $missinglistbefore ) {
$missinglist =~ s/\|\s\|/\|/g;
$missinglist =~ s/^\| //g;
$missinglist =~ s/\|$//g;
- my $sth2= $dbh->prepare("UPDATE subscriptionhistory
+ my $sth2 = $dbh->prepare(
+ "UPDATE subscriptionhistory
SET missinglist = ?
- WHERE subscriptionid = ?");
- $sth2->execute($missinglist,$subscriptionid);
+ WHERE subscriptionid = ?"
+ );
+ $sth2->execute( $missinglist, $subscriptionid );
}
}
@@ -1409,12 +2011,15 @@
=back
=cut
+
sub updateClaim {
my ($serialid) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("UPDATE serial SET claimdate = now()
+ my $sth = $dbh->prepare(
+ "UPDATE serial SET claimdate = now()
WHERE serialid = ?
- ");
+ "
+ );
$sth->execute($serialid);
}
@@ -1432,14 +2037,17 @@
=back
=cut
+
sub getsupplierbyserialid {
my ($serialid) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT serialid, serial.subscriptionid, aqbooksellerid
+ my $sth = $dbh->prepare(
+ "SELECT serialid, serial.subscriptionid, aqbooksellerid
FROM serial, subscription
WHERE serial.subscriptionid = subscription.subscriptionid
AND serialid = ?
- ");
+ "
+ );
$sth->execute($serialid);
my $line = $sth->fetchrow_hashref;
my $result = $line->{'aqbooksellerid'};
@@ -1457,13 +2065,16 @@
=back
=cut
+
sub check_routing {
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT count(routingid) routingids FROM subscriptionroutinglist, subscription
+ my $sth = $dbh->prepare(
+"SELECT count(routingid) routingids FROM subscriptionroutinglist, subscription
WHERE subscription.subscriptionid = subscriptionroutinglist.subscriptionid
AND subscription.subscriptionid = ? ORDER BY ranking ASC
- ");
+ "
+ );
$sth->execute($subscriptionid);
my $line = $sth->fetchrow_hashref;
my $result = $line->{'routingids'};
@@ -1474,7 +2085,7 @@
=over 4
-&addroutingmember($bornum,$subscriptionid)
+&addroutingmember($borrowernumber,$subscriptionid)
this function takes a borrowernumber and subscriptionid and add the member to the
routing list for that serial subscription and gives them a rank on the list
@@ -1483,21 +2094,29 @@
=back
=cut
+
sub addroutingmember {
- my ($bornum,$subscriptionid) = @_;
+ my ( $borrowernumber, $subscriptionid ) = @_;
my $rank;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT max(ranking) rank FROM subscriptionroutinglist WHERE subscriptionid = ?");
+ my $sth =
+ $dbh->prepare(
+"SELECT max(ranking) rank FROM subscriptionroutinglist WHERE subscriptionid = ?"
+ );
$sth->execute($subscriptionid);
- while(my $line = $sth->fetchrow_hashref){
- if($line->{'rank'}>0){
- $rank = $line->{'rank'}+1;
- } else {
+ while ( my $line = $sth->fetchrow_hashref ) {
+ if ( $line->{'rank'} > 0 ) {
+ $rank = $line->{'rank'} + 1;
+ }
+ else {
$rank = 1;
}
}
- $sth = $dbh->prepare("INSERT INTO subscriptionroutinglist VALUES (null,?,?,?,null)");
- $sth->execute($subscriptionid,$bornum,$rank);
+ $sth =
+ $dbh->prepare(
+"INSERT INTO subscriptionroutinglist (subscriptionid,borrowernumber,ranking) VALUES (?,?,?)"
+ );
+ $sth->execute( $subscriptionid, $borrowernumber, $rank );
}
=head2 reorder_members
@@ -1517,32 +2136,44 @@
=back
=cut
+
sub reorder_members {
- my ($subscriptionid,$routingid,$rank) = @_;
+ my ( $subscriptionid, $routingid, $rank ) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT * FROM subscriptionroutinglist WHERE subscriptionid = ? ORDER BY ranking ASC");
+ my $sth =
+ $dbh->prepare(
+"SELECT * FROM subscriptionroutinglist WHERE subscriptionid = ? ORDER BY ranking ASC"
+ );
$sth->execute($subscriptionid);
my @result;
- while(my $line = $sth->fetchrow_hashref){
- push(@result,$line->{'routingid'});
+ while ( my $line = $sth->fetchrow_hashref ) {
+ push( @result, $line->{'routingid'} );
}
+
# To find the matching index
my $i;
my $key = -1; # to allow for 0 being a valid response
- for ($i = 0; $i < @result; $i++) {
- if ($routingid == $result[$i]) {
+ for ( $i = 0 ; $i < @result ; $i++ ) {
+ if ( $routingid == $result[$i] ) {
$key = $i; # save the index
last;
}
}
+
# if index exists in array then move it to new position
- if($key > -1 && $rank > 0){
- my $new_rank = $rank-1; # $new_rank is what you want the new index to be in the array
- my $moving_item = splice(@result, $key, 1);
- splice(@result, $new_rank, 0, $moving_item);
- }
- for(my $j = 0; $j < @result; $j++){
- my $sth = $dbh->prepare("UPDATE subscriptionroutinglist SET ranking = '" . ($j+1) . "' WHERE routingid = '". $result[$j]."'");
+ if ( $key > -1 && $rank > 0 ) {
+ my $new_rank = $rank -
+ 1; # $new_rank is what you want the new index to be in the array
+ my $moving_item = splice( @result, $key, 1 );
+ splice( @result, $new_rank, 0, $moving_item );
+ }
+ for ( my $j = 0 ; $j < @result ; $j++ ) {
+ my $sth =
+ $dbh->prepare( "UPDATE subscriptionroutinglist SET ranking = '"
+ . ( $j + 1 )
+ . "' WHERE routingid = '"
+ . $result[$j]
+ . "'" );
$sth->execute;
}
}
@@ -1559,16 +2190,23 @@
=back
=cut
+
sub delroutingmember {
- # if $routingid exists then deletes that row otherwise deletes all with $subscriptionid
- my ($routingid,$subscriptionid) = @_;
+
+# if $routingid exists then deletes that row otherwise deletes all with $subscriptionid
+ my ( $routingid, $subscriptionid ) = @_;
my $dbh = C4::Context->dbh;
- if($routingid){
- my $sth = $dbh->prepare("DELETE FROM subscriptionroutinglist WHERE routingid = ?");
+ if ($routingid) {
+ my $sth =
+ $dbh->prepare(
+ "DELETE FROM subscriptionroutinglist WHERE routingid = ?");
$sth->execute($routingid);
- reorder_members($subscriptionid,$routingid);
- } else {
- my $sth = $dbh->prepare("DELETE FROM subscriptionroutinglist WHERE subscriptionid = ?");
+ reorder_members( $subscriptionid, $routingid );
+ }
+ else {
+ my $sth =
+ $dbh->prepare(
+ "DELETE FROM subscriptionroutinglist WHERE subscriptionid = ?");
$sth->execute($subscriptionid);
}
}
@@ -1589,22 +2227,25 @@
=back
=cut
+
sub getroutinglist {
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
- my $sth = $dbh->prepare("SELECT routingid, borrowernumber,
+ my $sth = $dbh->prepare(
+ "SELECT routingid, borrowernumber,
ranking, biblionumber FROM subscriptionroutinglist, subscription
WHERE subscription.subscriptionid = subscriptionroutinglist.subscriptionid
AND subscription.subscriptionid = ? ORDER BY ranking ASC
- ");
+ "
+ );
$sth->execute($subscriptionid);
my @routinglist;
- my $count=0;
- while (my $line = $sth->fetchrow_hashref) {
+ my $count = 0;
+ while ( my $line = $sth->fetchrow_hashref ) {
$count++;
- push(@routinglist,$line);
+ push( @routinglist, $line );
}
- return ($count, at routinglist);
+ return ( $count, @routinglist );
}
=head2 abouttoexpire
@@ -1626,57 +2267,273 @@
my ($subscriptionid) = @_;
my $dbh = C4::Context->dbh;
my $subscription = GetSubscription($subscriptionid);
- # we don't do the same test if the subscription is based on X numbers or on X weeks/months
- if ($subscription->{numberlength}) {
- my $sth = $dbh->prepare("select count(*) from serial where subscriptionid=? and planneddate>=?");
- $sth->execute($subscriptionid,$subscription->{startdate});
- my $res = $sth->fetchrow;
- # warn "length: ".$subscription->{numberlength}." vs count: ".$res;
- if ($subscription->{numberlength}==$res) {
- return 1;
- } else {
- return 0;
- }
- } else {
- # a little bit more tricky if based on X weeks/months : search if the latest issue waited is not after subscription startdate + duration
- my $sth = $dbh->prepare("select max(planneddate) from serial where subscriptionid=?");
- $sth->execute($subscriptionid);
- my $res = $sth->fetchrow;
- my $endofsubscriptiondate;
-my $duration;
- $duration=get_duration($subscription->{monthlength}." months") if ($subscription->{monthlength});
- $duration=get_duration($subscription->{weeklength}." weeks") if ($subscription->{weeklength});
-
- $endofsubscriptiondate = DATE_Add_Duration($subscription->{startdate},$duration) ;
+ my $expirationdate = GetExpirationDate($subscriptionid);
+ my $sth =
+ $dbh->prepare(
+ "select max(planneddate) from serial where subscriptionid=?");
+ $sth->execute($subscriptionid);
+ my ($res) = $sth->fetchrow ;
+# warn "date expiration : ".$expirationdate." date courante ".$res;
+ my @res=split /-/,$res;
+ my @endofsubscriptiondate=split/-/,$expirationdate;
my $per = $subscription->{'periodicity'};
- my $x = 0;
- if ($per == 1) { $x = '1 days'; }
- if ($per == 2) { $x = '1 weeks'; }
- if ($per == 3) { $x = '2 weeks'; }
- if ($per == 4) { $x = '3 weeks'; }
- if ($per == 5) { $x = '1 months'; }
- if ($per == 6) { $x = '2 months'; }
- if ($per == 7 || $per == 8) { $x = '3 months'; }
- if ($per == 9) { $x = '6 months'; }
- if ($per == 10) { $x = '1 years'; }
- if ($per == 11) { $x = '2 years'; }
- my $duration=get_duration("-".$x) ;
- my $datebeforeend = DATE_Add_Duration($endofsubscriptiondate,$duration); # if ($subscription->{weeklength});
+ my $x;
+ if ( $per == 1 ) {$x=7;}
+ if ( $per == 2 ) {$x=7; }
+ if ( $per == 3 ) {$x=14;}
+ if ( $per == 4 ) { $x = 21; }
+ if ( $per == 5 ) { $x = 31; }
+ if ( $per == 6 ) { $x = 62; }
+ if ( $per == 7 || $per == 8 ) { $x = 93; }
+ if ( $per == 9 ) { $x = 190; }
+ if ( $per == 10 ) { $x = 365; }
+ if ( $per == 11 ) { $x = 730; }
+ my @datebeforeend=Add_Delta_Days( $endofsubscriptiondate[0],$endofsubscriptiondate[1],$endofsubscriptiondate[2],
+ - (3 * $x)) if (@endofsubscriptiondate);
# warn "DATE BEFORE END: $datebeforeend";
- return 1 if ($res >= $datebeforeend && $res < $endofsubscriptiondate);
+ return 1 if ( @res &&
+ (@datebeforeend &&
+ Delta_Days($res[0],$res[1],$res[2],
+ $datebeforeend[0],$datebeforeend[1],$datebeforeend[2]) <= 0) &&
+ (@endofsubscriptiondate &&
+ Delta_Days($res[0],$res[1],$res[2],
+ $endofsubscriptiondate[0],$endofsubscriptiondate[1],$endofsubscriptiondate[2]) >= 0) );
return 0;
- }
}
+=head2 old_newsubscription
+=over 4
-=head2 GetNextDate
+($subscriptionid) = &old_newsubscription($auser,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
+ $startdate,$periodicity,$firstacquidate,$dow,$irregularity,$numberpattern,$numberlength,$weeklength,$monthlength,
+ $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,
+ $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,
+ $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,
+ $numberingmethod, $status, $callnumber, $notes, $hemisphere)
+
+this function is similar to the NewSubscription subroutine but has a few different
+values passed in
+$firstacquidate - date of first serial issue to arrive
+$irregularity - the issues not expected separated by a '|'
+- eg. monthly issue but not expecting issue for june and july would have $irregularity of '6|7'
+$numberpattern - the number for an array of labels to reconstruct the javascript correctly in the
+ subscription-add.tmpl file
+$callnumber - display the callnumber of the serial
+$hemisphere - either 2 = southern hemisphere or 1 = northern hemisphere - used for quarterly serials
+
+return :
+the $subscriptionid number of the new subscription
+
+=back
+
+=cut
+
+sub old_newsubscription {
+ my (
+ $auser, $aqbooksellerid, $cost, $aqbudgetid,
+ $biblionumber, $startdate, $periodicity, $firstacquidate,
+ $dow, $irregularity, $numberpattern, $numberlength,
+ $weeklength, $monthlength, $add1, $every1,
+ $whenmorethan1, $setto1, $lastvalue1, $add2,
+ $every2, $whenmorethan2, $setto2, $lastvalue2,
+ $add3, $every3, $whenmorethan3, $setto3,
+ $lastvalue3, $numberingmethod, $status, $callnumber,
+ $notes, $hemisphere
+ ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ #save subscription
+ my $sth = $dbh->prepare(
+"insert into subscription (librarian,aqbooksellerid,cost,aqbudgetid,biblionumber,
+ startdate,periodicity,firstacquidate,dow,irregularity,numberpattern,numberlength,weeklength,monthlength,
+ add1,every1,whenmorethan1,setto1,lastvalue1,
+ add2,every2,whenmorethan2,setto2,lastvalue2,
+ add3,every3,whenmorethan3,setto3,lastvalue3,
+ numberingmethod, status, callnumber, notes, hemisphere) values
+ (?,?,?,?,?,?,?,?,?,?,?,
+ ?,?,?,?,?,?,?,?,?,?,?,
+ ?,?,?,?,?,?,?,?,?,?,?,?)"
+ );
+ $sth->execute(
+ $auser, $aqbooksellerid,
+ $cost, $aqbudgetid,
+ $biblionumber, format_date_in_iso($startdate),
+ $periodicity, format_date_in_iso($firstacquidate),
+ $dow, $irregularity,
+ $numberpattern, $numberlength,
+ $weeklength, $monthlength,
+ $add1, $every1,
+ $whenmorethan1, $setto1,
+ $lastvalue1, $add2,
+ $every2, $whenmorethan2,
+ $setto2, $lastvalue2,
+ $add3, $every3,
+ $whenmorethan3, $setto3,
+ $lastvalue3, $numberingmethod,
+ $status, $callnumber,
+ $notes, $hemisphere
+ );
+
+ #then create the 1st waited number
+ my $subscriptionid = $dbh->{'mysql_insertid'};
+ my $enddate = GetExpirationDate($subscriptionid);
+
+ $sth =
+ $dbh->prepare(
+"insert into subscriptionhistory (biblionumber, subscriptionid, histstartdate, enddate, missinglist, recievedlist, opacnote, librariannote) values (?,?,?,?,?,?,?,?)"
+ );
+ $sth->execute(
+ $biblionumber, $subscriptionid,
+ format_date_in_iso($startdate),
+ format_date_in_iso($enddate),
+ "", "", "", $notes
+ );
+
+ # reread subscription to get a hash (for calculation of the 1st issue number)
+ $sth =
+ $dbh->prepare("select * from subscription where subscriptionid = ? ");
+ $sth->execute($subscriptionid);
+ my $val = $sth->fetchrow_hashref;
+
+ # calculate issue number
+ my $serialseq = GetSeq($val);
+ $sth =
+ $dbh->prepare(
+"insert into serial (serialseq,subscriptionid,biblionumber,status, planneddate) values (?,?,?,?,?)"
+ );
+ $sth->execute( $serialseq, $subscriptionid, $val->{'biblionumber'},
+ 1, format_date_in_iso($startdate) );
+ return $subscriptionid;
+}
+
+=head2 old_modsubscription
=over 4
+($subscriptionid) = &old_modsubscription($auser,$aqbooksellerid,$cost,$aqbudgetid,$biblionumber,
+ $startdate,$periodicity,$firstacquidate,$dow,$irregularity,$numberpattern,$numberlength,$weeklength,$monthlength,
+ $add1,$every1,$whenmorethan1,$setto1,$lastvalue1,
+ $add2,$every2,$whenmorethan2,$setto2,$lastvalue2,
+ $add3,$every3,$whenmorethan3,$setto3,$lastvalue3,
+ $numberingmethod, $status, $callnumber, $notes, $hemisphere, $subscriptionid)
+
+this function is similar to the ModSubscription subroutine but has a few different
+values passed in
+$firstacquidate - date of first serial issue to arrive
+$irregularity - the issues not expected separated by a '|'
+- eg. monthly issue but not expecting issue for june and july would have $irregularity of '6|7'
+$numberpattern - the number for an array of labels to reconstruct the javascript correctly in the
+ subscription-add.tmpl file
+$callnumber - display the callnumber of the serial
+$hemisphere - either 2 = southern hemisphere or 1 = northern hemisphere - used for quarterly serials
+
+=back
+
+=cut
+
+sub old_modsubscription {
+ my (
+ $auser, $aqbooksellerid, $cost, $aqbudgetid,
+ $startdate, $periodicity, $firstacquidate, $dow,
+ $irregularity, $numberpattern, $numberlength, $weeklength,
+ $monthlength, $add1, $every1, $whenmorethan1,
+ $setto1, $lastvalue1, $innerloop1, $add2,
+ $every2, $whenmorethan2, $setto2, $lastvalue2,
+ $innerloop2, $add3, $every3, $whenmorethan3,
+ $setto3, $lastvalue3, $innerloop3, $numberingmethod,
+ $status, $biblionumber, $callnumber, $notes,
+ $hemisphere, $subscriptionid
+ ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+"update subscription set librarian=?, aqbooksellerid=?,cost=?,aqbudgetid=?,startdate=?,
+ periodicity=?,firstacquidate=?,dow=?,irregularity=?,numberpattern=?,numberlength=?,weeklength=?,monthlength=?,
+ add1=?,every1=?,whenmorethan1=?,setto1=?,lastvalue1=?,innerloop1=?,
+ add2=?,every2=?,whenmorethan2=?,setto2=?,lastvalue2=?,innerloop2=?,
+ add3=?,every3=?,whenmorethan3=?,setto3=?,lastvalue3=?,innerloop3=?,
+ numberingmethod=?, status=?, biblionumber=?, callnumber=?, notes=?, hemisphere=? where subscriptionid = ?"
+ );
+ $sth->execute(
+ $auser, $aqbooksellerid, $cost, $aqbudgetid,
+ $startdate, $periodicity, $firstacquidate, $dow,
+ $irregularity, $numberpattern, $numberlength, $weeklength,
+ $monthlength, $add1, $every1, $whenmorethan1,
+ $setto1, $lastvalue1, $innerloop1, $add2,
+ $every2, $whenmorethan2, $setto2, $lastvalue2,
+ $innerloop2, $add3, $every3, $whenmorethan3,
+ $setto3, $lastvalue3, $innerloop3, $numberingmethod,
+ $status, $biblionumber, $callnumber, $notes,
+ $hemisphere, $subscriptionid
+ );
+ $sth->finish;
+
+ $sth =
+ $dbh->prepare("select * from subscription where subscriptionid = ? ");
+ $sth->execute($subscriptionid);
+ my $val = $sth->fetchrow_hashref;
+
+ # calculate issue number
+ my $serialseq = Get_Seq($val);
+ $sth =
+ $dbh->prepare("UPDATE serial SET serialseq = ? WHERE subscriptionid = ?");
+ $sth->execute( $serialseq, $subscriptionid );
+
+ my $enddate = subscriptionexpirationdate($subscriptionid);
+ $sth = $dbh->prepare("update subscriptionhistory set enddate=?");
+ $sth->execute( format_date_in_iso($enddate) );
+}
+
+=head2 old_getserials
+
+=over 4
+
+($totalissues, at serials) = &old_getserials($subscriptionid)
+
+this function get a hashref of serials and the total count of them
+
+return :
+$totalissues - number of serial lines
+the serials into a table. Each line of this table containts a ref to a hash which it containts
+serialid, serialseq, status,planneddate,notes,routingnotes from tables : serial where status is not 2, 4, or 5
+
+=back
+
+=cut
+
+sub old_getserials {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # status = 2 is "arrived"
+ my $sth =
+ $dbh->prepare(
+"select serialid,serialseq, status, planneddate,notes,routingnotes from serial where subscriptionid = ? and status <>2 and status <>4 and status <>5"
+ );
+ $sth->execute($subscriptionid);
+ my @serials;
+ my $num = 1;
+ while ( my $line = $sth->fetchrow_hashref ) {
+ $line->{ "status" . $line->{status} } =
+ 1; # fills a "statusX" value, used for template status select list
+ $line->{"planneddate"} = format_date( $line->{"planneddate"} );
+ $line->{"num"} = $num;
+ $num++;
+ push @serials, $line;
+ }
+ $sth = $dbh->prepare("select count(*) from serial where subscriptionid=?");
+ $sth->execute($subscriptionid);
+ my ($totalissues) = $sth->fetchrow;
+ return ( $totalissues, @serials );
+}
+
+=head2 GetNextDate
+
($resultdate) = &GetNextDate($planneddate,$subscription)
-this function takes the planneddate and will return the next issue's date and will skip dates if there
+this function is an extension of GetNextDate which allows for checking for irregularity
+
+it takes the planneddate and will return the next issue's date and will skip dates if there
exists an irregularity
- eg if periodicity is monthly and $planneddate is 2007-02-10 but if March and April is to be
skipped then the returned date will be 2007-05-10
@@ -1684,136 +2541,164 @@
return :
$resultdate - then next date in the sequence
-=back
+FIXME : have to replace Date::Manip by Date::Calc in this function to improve performances.
=cut
-sub GetNextDate {
- my ($planneddate,$subscription) = @_;
- my @irreg = split(/\|/,$subscription->{irregularity});
- my $dateobj=DATE_obj($planneddate);
- my $dayofweek = $dateobj->day_of_week;
- my $month=$dateobj->month;
- my $resultdate;
-
- if ($subscription->{periodicity} == 1) {
- my %irreghash;
- for(my $i=0;$i<@irreg;$i++){
- $irreghash{$irreg[$i]}=1;
- }
-my $duration=get_duration("1 days");
- for(my $i=0;$i<@irreg;$i++){
- if($dayofweek == 7){ $dayofweek = 0; }
+sub in_array { # used in next sub down
+ my ($val, at elements) = @_;
+ foreach my $elem(@elements) {
+ if($val == $elem) {
+ return 1;
+ }
+ }
+ return 0;
+}
- if($irreghash{$dayofweek+1}){
- $planneddate = DATE_Add_Duration($planneddate,$duration);
+sub GetNextDate(@) {
+ my ( $planneddate, $subscription ) = @_;
+ my @irreg = split( /\,/, $subscription->{irregularity} );
+
+ #date supposed to be in ISO.
+
+ my ( $year, $month, $day ) = split(/-/, $planneddate);
+ $month=1 unless ($month);
+ $day=1 unless ($day);
+ my @resultdate;
+
+ # warn "DOW $dayofweek";
+ if ( $subscription->{periodicity} == 1 ) {
+ my $dayofweek = Day_of_Week( $year,$month, $day );
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ $dayofweek = 0 if ( $dayofweek == 7 );
+ if ( in_array( ($dayofweek + 1), @irreg ) ) {
+ ($year,$month,$day) = Add_Delta_Days($year,$month, $day , 1 );
$dayofweek++;
}
}
- $resultdate=DATE_Add_Duration($planneddate,$duration);
+ @resultdate = Add_Delta_Days($year,$month, $day , 1 );
+ }
+ if ( $subscription->{periodicity} == 2 ) {
+ my ($wkno,$year) = Week_of_Year( $year,$month, $day );
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($wkno!=51)?($wkno +1) % 52 :52)) {
+ ($year,$month,$day) = Add_Delta_Days($year,$month, $day , 7 );
+ $wkno=(($wkno!=51)?($wkno +1) % 52 :52);
+ }
+ }
+ @resultdate = Add_Delta_Days( $year,$month, $day, 7);
+ }
+ if ( $subscription->{periodicity} == 3 ) {
+ my ($wkno,$year) = Week_of_Year( $year,$month, $day );
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($wkno!=50)?($wkno +2) % 52 :52)) {
+ ### BUGFIX was previously +1 ^
+ ($year,$month,$day) = Add_Delta_Days($year,$month, $day , 14 );
+ $wkno=(($wkno!=50)?($wkno +2) % 52 :52);
+ }
+ }
+ @resultdate = Add_Delta_Days($year,$month, $day , 14 );
+ }
+ if ( $subscription->{periodicity} == 4 ) {
+ my ($wkno,$year) = Week_of_Year( $year,$month, $day );
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($wkno!=49)?($wkno +3) % 52 :52)) {
+ ($year,$month,$day) = Add_Delta_Days($year,$month, $day , 21 );
+ $wkno=(($wkno!=49)?($wkno +3) % 52 :52);
+ }
+ }
+ @resultdate = Add_Delta_Days($year,$month, $day , 21 );
+ }
+ my $tmpmonth=$month;
+ if ( $subscription->{periodicity} == 5 ) {
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($tmpmonth!=11)?($tmpmonth +1) % 12 :12)) {
+ ($year,$month,$day) = Add_Delta_YMD($year,$month, $day ,0,1,0 );
+ $tmpmonth=(($tmpmonth!=11)?($tmpmonth +1) % 12 :12);
+ }
+ }
+ @resultdate = Add_Delta_YMD($year,$month, $day ,0,1,0 );
+ }
+ if ( $subscription->{periodicity} == 6 ) {
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($tmpmonth!=10)?($tmpmonth +2) % 12 :12)) {
+ ($year,$month,$day) = Add_Delta_YMD($year,$month, $day ,0,2,0 );
+ $tmpmonth=(($tmpmonth!=10)?($tmpmonth + 2) % 12 :12);
+ }
}
- if ($subscription->{periodicity} == 2) {
- my $wkno = $dateobj->week_number;
-my $duration=get_duration("1 weeks");
- for(my $i = 0;$i < @irreg; $i++){
- if($wkno > 52) { $wkno = 0; } # need to rollover at January
- if($irreg[$i] == ($wkno+1)){
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $wkno++;
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 3) {
- my $wkno = $dateobj->week_number;
-my $duration=get_duration("2 weeks");
- for(my $i = 0;$i < @irreg; $i++){
- if($wkno > 52) { $wkno = 0; } # need to rollover at January
- if($irreg[$i] == ($wkno+1)){
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $wkno++;
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 4) {
- my $wkno = $dateobj->week_number;
-my $duration=get_duration("3 weeks");
- for(my $i = 0;$i < @irreg; $i++){
- if($wkno > 52) { $wkno = 0; } # need to rollover at January
- if($irreg[$i] == ($wkno+1)){
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $wkno++;
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 5) {
-my $duration=get_duration("1 months");
- for(my $i = 0;$i < @irreg; $i++){
- # warn $irreg[$i];
- # warn $month;
- if($month == 12) { $month = 0; } # need to rollover to check January
- if($irreg[$i] == ($month+1)){ # check next one to see if is to be skipped
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $month++; # to check if following ones are to be skipped too
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 6) {
-my $duration=get_duration("2 months");
- for(my $i = 0;$i < @irreg; $i++){
- # warn $irreg[$i];
- # warn $month;
- if($month == 12) { $month = 0; } # need to rollover to check January
- if($irreg[$i] == ($month+1)){ # check next one to see if is to be skipped
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $month++; # to check if following ones are to be skipped too
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 7 || $subscription->{periodicity} == 8 ) {
-my $duration=get_duration("3 months");
- for(my $i = 0;$i < @irreg; $i++){
- # warn $irreg[$i];
- # warn $month;
- if($month == 12) { $month = 0; } # need to rollover to check January
- if($irreg[$i] == ($month+1)){ # check next one to see if is to be skipped
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $month++; # to check if following ones are to be skipped too
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
-
- if ($subscription->{periodicity} == 9) {
-my $duration=get_duration("6 months");
- for(my $i = 0;$i < @irreg; $i++){
- # warn $irreg[$i];
- # warn $month;
- if($month == 12) { $month = 0; } # need to rollover to check January
- if($irreg[$i] == ($month+1)){ # check next one to see if is to be skipped
- $planneddate = DATE_Add_Duration($planneddate,$duration);
- $month++; # to check if following ones are to be skipped too
- }
- }
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 10) {
-my $duration=get_duration("1 years");
- $resultdate=DATE_Add_Duration($planneddate,$duration);
- }
- if ($subscription->{periodicity} == 11) {
- my $duration=get_duration("2 years");
- $resultdate=DATE_Add_Duration($planneddate,$duration);
+ @resultdate = Add_Delta_YMD($year,$month, $day, 0, 2,0 );
}
- # warn "date: ".$resultdate;
- return $resultdate;
+ if ( $subscription->{periodicity} == 7 ) {
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($tmpmonth!=9)?($tmpmonth +3) % 12 :12)) {
+ ($year,$month,$day) = Add_Delta_YMD($year,$month, $day, 0, 3,0 );
+ $tmpmonth=(($tmpmonth!=9)?($tmpmonth + 3) % 12 :12);
+ }
+ }
+ @resultdate = Add_Delta_YMD($year,$month, $day, 0, 3, 0);
+ }
+ if ( $subscription->{periodicity} == 8 ) {
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($tmpmonth!=9)?($tmpmonth +3) % 12 :12)) {
+ ($year,$month,$day) = Add_Delta_YMD($year,$month, $day, 0, 3,0 );
+ $tmpmonth=(($tmpmonth!=9)?($tmpmonth + 3) % 12 :12);
+ }
+ }
+ @resultdate = Add_Delta_YMD($year,$month, $day, 0, 3, 0);
+ }
+ if ( $subscription->{periodicity} == 9 ) {
+ for ( my $i = 0 ; $i < @irreg ; $i++ ) {
+ if ( $irreg[$i] == (($tmpmonth!=9)?($tmpmonth +3) % 12 :12)) {
+ ### BUFIX Seems to need more Than One ?
+ ($year,$month,$day) = Add_Delta_YM($year,$month, $day, 0, 6 );
+ $tmpmonth=(($tmpmonth!=6)?($tmpmonth + 6) % 12 :12);
+ }
+ }
+ @resultdate = Add_Delta_YM($year,$month, $day, 0, 6);
+ }
+ if ( $subscription->{periodicity} == 10 ) {
+ @resultdate = Add_Delta_YM($year,$month, $day, 1, 0 );
+ }
+ if ( $subscription->{periodicity} == 11 ) {
+ @resultdate = Add_Delta_YM($year,$month, $day, 2, 0 );
+ }
+ my $resultdate=sprintf("%04d-%02d-%02d",$resultdate[0],$resultdate[1],$resultdate[2]);
+# warn "dateNEXTSEQ : ".$resultdate;
+ return "$resultdate";
}
+=head2 itemdata
+
+ $item = &itemdata($barcode);
+
+Looks up the item with the given barcode, and returns a
+reference-to-hash containing information about that item. The keys of
+the hash are the fields from the C<items> and C<biblioitems> tables in
+the Koha database.
+=cut
+
+#'
+sub itemdata {
+ my ($barcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "Select * from items,biblioitems where barcode=?
+ and items.biblioitemnumber=biblioitems.biblioitemnumber"
+ );
+ $sth->execute($barcode);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return ($data);
+}
END { } # module clean-up code here (global destructor)
1;
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Stats.pm
===================================================================
RCS file: /sources/koha/koha/C4/Stats.pm,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -b -r1.28 -r1.29
--- Stats.pm 15 Nov 2006 01:36:00 -0000 1.28
+++ Stats.pm 9 Mar 2007 14:31:47 -0000 1.29
@@ -1,7 +1,7 @@
package C4::Stats;
-# $Id: Stats.pm,v 1.28 2006/11/15 01:36:00 tgarip1957 Exp $
-# Modified by TG
+# $Id: Stats.pm,v 1.29 2007/03/09 14:31:47 tipaul Exp $
+
# Copyright 2000-2002 Katipo Communications
#
# This file is part of Koha.
@@ -21,12 +21,14 @@
use strict;
require Exporter;
-
+use DBI;
use C4::Context;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = $VERSION = do { my @v = '$Revision: 1.29 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
=head1 NAME
@@ -49,7 +51,8 @@
@ISA = qw(Exporter);
@EXPORT = qw(&UpdateStats &statsreport &TotalOwing
-&TotalPaid &getcharges &Getpaidbranch &unfilledreserves &getcredits &getinvoices);
+ &TotalPaid &getcharges &Getpaidbranch &unfilledreserves &getcredits
+ getrefunds);
=item UpdateStats
@@ -69,144 +72,175 @@
C<$env-E<gt>{usercode}> specifies the value of the C<usercode> field.
=cut
+
#'
sub UpdateStats {
+
#module to insert stats data into stats table
- my ($env,$branch,$type,$amount,$other,$itemnum,$itemtype,$borrowernumber,$accountno)=@_;
+ my (
+ $env, $branch, $type,
+ $amount, $other, $itemnum,
+ $itemtype, $borrowernumber, $accountno
+ )
+ = @_;
my $dbh = C4::Context->dbh;
- $env=C4::Context->userenv unless $env;
- if ($branch eq ''){
- $branch=$env->{'branchcode'};
- }
- my $user = C4::Context->userenv;
-# print $borrowernumber;
- my $userid=$user->{'cardnumber'} if $user;
+ if ( $branch eq '' ) {
+ $branch = $env->{'branchcode'};
+ }
+ my $user = $env->{'usercode'};
+ my $organisation = $env->{'organisation'};
+
# FIXME - Use $dbh->do() instead
- my $sth=$dbh->prepare("Insert into statistics (datetime,branch,type,usercode,value,
- other,itemnumber,itemtype,borrowernumber,proccode) values (now(),?,?,?,?,?,?,?,?,?)");
- $sth->execute($branch,$type,$userid,$amount,$other,$itemnum,$itemtype,$borrowernumber,$accountno);
+ my $sth = $dbh->prepare(
+ "Insert into statistics (datetime,branch,type,usercode,value,
+ other,itemnumber,itemtype,borrowernumber,proccode,associatedborrower) values (now(),?,?,?,?,?,?,?,?,?,?)"
+ );
+ $sth->execute(
+ $branch, $type, $user, $amount,
+ $other, $itemnum, $itemtype, $borrowernumber,
+ $accountno, $organisation
+ );
$sth->finish;
}
# Otherwise, it'd need a POD.
sub TotalPaid {
- my ($time,$time2)=@_;
- $time2=$time unless $time2;
+ my ( $time, $time2, $spreadsheet ) = @_;
+ $time2 = $time unless $time2;
my $dbh = C4::Context->dbh;
-
-
- my $query="Select * from accountlines,borrowers where (accounttype = 'Pay' or accounttype='W')
- and accountlines.borrowernumber = borrowers.borrowernumber";
- my @bind = ();
- if ($time eq 'today'){
- $query .= " and date = now()";
- } else {
- $query.=" and date>=? and date<=?";
- @bind = ($time,$time2);
+ my $query = "SELECT * FROM statistics,borrowers
+ WHERE statistics.borrowernumber= borrowers.borrowernumber
+ AND (statistics.type='payment' OR statistics.type='writeoff') ";
+ if ( $time eq 'today' ) {
+ $query = $query . " AND datetime = now()";
}
-
-
-
-
- $query.=" order by timestamp";
-
- # print $query;
-
- my $sth=$dbh->prepare($query);
-
- # $sth->execute();
- $sth->execute(@bind);
+ else {
+ $query .= " AND datetime > '$time'";
+ }
+ if ( $time2 ne '' ) {
+ $query .= " AND datetime < '$time2'";
+ }
+ if ($spreadsheet) {
+ $query .= " ORDER BY branch, type";
+ }
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
my @results;
- my $i=0;
- while (my $data=$sth->fetchrow_hashref){
- $results[$i]=$data;
- $i++;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
}
$sth->finish;
- # print $query;
- return(@results);
+ return (@results);
}
# Otherwise, it needs a POD.
-sub getcharges{
- my($borrowerno,$offset,$accountno)=@_;
+sub getcharges {
+ my ( $borrowerno, $timestamp, $accountno ) = @_;
my $dbh = C4::Context->dbh;
- my $query="";
+ my $timestamp2 = $timestamp - 1;
+ my $query = "";
my $sth;
# getcharges is now taking accountno. as an argument
- if ($offset){
- $sth=$dbh->prepare("Select * from accountlines where borrowernumber=?
- and accountno = ? and amount>0");
- $sth->execute($borrowerno,$offset);
+ if ($accountno) {
+ $sth = $dbh->prepare(
+ "Select * from accountlines where borrowernumber=?
+ and accountno = ?"
+ );
+ $sth->execute( $borrowerno, $accountno );
# this bit left in for old 2 arg usage of getcharges
- } else {
- $sth=$dbh->prepare("Select * from accountlines where borrowernumber=?
- and accountno = ?");
- $sth->execute($borrowerno,$accountno);
+ }
+ else {
+ $sth = $dbh->prepare(
+ "Select * from accountlines where borrowernumber=?
+ and timestamp = ? and accounttype <> 'Pay' and
+ accounttype <> 'W'"
+ );
+ $sth->execute( $borrowerno, $timestamp );
}
# print $query,"<br>";
- my $i=0;
+ my $i = 0;
my @results;
- while (my $data=$sth->fetchrow_hashref){
+ while ( my $data = $sth->fetchrow_hashref ) {
+
# if ($data->{'timestamp'} == $timestamp){
- $results[$i]=$data;
+ $results[$i] = $data;
$i++;
+
# }
}
- return(@results);
+ return (@results);
}
# Otherwise, it needs a POD.
-sub getcredits{
- my ($date,$date2)=@_;
+sub getcredits {
+ my ( $date, $date2 ) = @_;
my $dbh = C4::Context->dbh;
+ #takes date converts to timestamps
+ my $padding = "000000";
+ ( my $a, my $b, my $c ) = unpack( "A4 x1 A2 x1 A2", $date );
+ ( my $x, my $y, my $z ) = unpack( "A4 x1 A2 x1 A2", $date2 );
+ my $timestamp = $a . $b . $c . $padding;
+ my $timestamp2 = $x . $y . $z . $padding;
-
- my $sth=$dbh->prepare("Select * from accountlines,borrowers where (( (accounttype <> 'Pay'))
+ my $sth = $dbh->prepare(
+"Select * from accountlines,borrowers where (((accounttype = 'LR') or (accounttype <> 'Pay'))
and amount < 0 and accountlines.borrowernumber = borrowers.borrowernumber
- and date >=? and date <=?)");
- $sth->execute($date, $date2);
+ and timestamp >=? and timestamp <?)"
+ );
+ $sth->execute( $timestamp, $timestamp2 );
- my $i=0;
+ my $i = 0;
my @results;
- while (my $data=$sth->fetchrow_hashref){
- $results[$i]=$data;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $results[$i] = $data;
$i++;
}
- return(@results);
+ return (@results);
}
-sub getinvoices{
- my ($date,$date2)=@_;
+sub getrefunds {
+ my ( $date, $date2 ) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("Select * from accountlines,borrowers where amount>0 and amountoutstanding > 0 and accountlines.borrowernumber = borrowers.borrowernumber
- and (date >=? and date <=?)");
- $sth->execute($date, $date2);
- my $i=0;
+ #takes date converts to timestamps
+ my $padding = "000000";
+ ( my $a, my $b, my $c ) = unpack( "A4 x1 A2 x1 A2", $date );
+ ( my $x, my $y, my $z ) = unpack( "A4 x1 A2 x1 A2", $date2 );
+ my $timestamp = $a . $b . $c . $padding;
+ my $timestamp2 = $x . $y . $z . $padding;
+
+ my $sth = $dbh->prepare(
+"Select * from accountlines,borrowers where (accounttype = 'REF'
+ and accountlines.borrowernumber = borrowers.borrowernumber
+ and timestamp >=? and timestamp <?)"
+ );
+ $sth->execute( $timestamp, $timestamp2 );
+
my @results;
- while (my $data=$sth->fetchrow_hashref){
- $results[$i]=$data;
- $i++;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data;
}
- return(@results);
+ return (@results);
}
-
# Otherwise, this needs a POD.
-sub Getpaidbranch{
- my($date,$borrno)=@_;
+sub Getpaidbranch {
+ my ( $date, $borrno ) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from statistics where type='payment' and datetime >? and borrowernumber=?");
- $sth->execute($date,$borrno);
+ my $sth =
+ $dbh->prepare(
+"select * from statistics where type='payment' and datetime >? and borrowernumber=?"
+ );
+ $sth->execute( $date, $borrno );
+
# print $query;
- my $data=$sth->fetchrow_hashref;
+ my $data = $sth->fetchrow_hashref;
$sth->finish;
- return($data->{'branch'});
+ return ( $data->{'branch'} );
}
# FIXME - This is only used in reservereport.pl and reservereport.xls,
@@ -214,22 +248,40 @@
# Otherwise, it needs a POD.
sub unfilledreserves {
my $dbh = C4::Context->dbh;
-
- my $i=0;
- my @results;
-
- my $sth=$dbh->prepare("select *,biblio.title from reserves,biblio,borrowers where (found <> '1' or found is NULL) and cancellationdate
+ my $sth = $dbh->prepare(
+"select *,biblio.title from reserves,reserveconstraints,biblio,borrowers,biblioitems where (found <> 'F' or
+ found is NULL) and cancellationdate
is NULL and biblio.biblionumber=reserves.biblionumber and
+ reserves.constrainttype='o'
+ and (reserves.biblionumber=reserveconstraints.biblionumber
+ and reserves.borrowernumber=reserveconstraints.borrowernumber)
+ and
+ reserves.borrowernumber=borrowers.borrowernumber and
+ biblioitems.biblioitemnumber=reserveconstraints.biblioitemnumber order by
+ biblio.title,reserves.reservedate"
+ );
+ $sth->execute;
+ my $i = 0;
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $results[$i] = $data;
+ $i++;
+ }
+ $sth->finish;
+ $sth = $dbh->prepare(
+"select *,biblio.title from reserves,biblio,borrowers where (found <> 'F' or found is NULL) and cancellationdate
+ is NULL and biblio.biblionumber=reserves.biblionumber and reserves.constrainttype='a' and
reserves.borrowernumber=borrowers.borrowernumber
order by
- reserves.reservedate,biblio.title");
+ biblio.title,reserves.reservedate"
+ );
$sth->execute;
- while (my $data=$sth->fetchrow_hashref){
- $results[$i]=$data;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $results[$i] = $data;
$i++;
}
$sth->finish;
- return($i,\@results);
+ return ( $i, \@results );
}
1;
Index: Suggestions.pm
===================================================================
RCS file: /sources/koha/koha/C4/Suggestions.pm,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- Suggestions.pm 20 Sep 2006 21:48:44 -0000 1.16
+++ Suggestions.pm 9 Mar 2007 14:31:47 -0000 1.17
@@ -17,17 +17,18 @@
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
-# $Id: Suggestions.pm,v 1.16 2006/09/20 21:48:44 tgarip1957 Exp $
+# $Id: Suggestions.pm,v 1.17 2007/03/09 14:31:47 tipaul Exp $
use strict;
require Exporter;
use C4::Context;
use C4::Output;
+use C4::Date;
use Mail::Sendmail;
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = do { my @v = '$Revision: 1.16 $' =~ /\d+/g;
+$VERSION = do { my @v = '$Revision: 1.17 $' =~ /\d+/g;
shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
=head1 NAME
@@ -40,8 +41,6 @@
=head1 DESCRIPTION
-=over 4
-
The functions in this module deal with the suggestions in OPAC and in librarian interface
A suggestion is done in the OPAC. It has the status "ASKED"
@@ -55,8 +54,6 @@
All suggestions of a borrower can be seen by the borrower itself.
Suggestions done by other borrowers can be seen when not "AVAILABLE"
-=back
-
=head1 FUNCTIONS
=cut
@@ -66,6 +63,7 @@
&NewSuggestion
&SearchSuggestion
&GetSuggestion
+ &GetSuggestionByStatus
&DelSuggestion
&CountSuggestion
&ModStatus
@@ -75,8 +73,6 @@
=head2 SearchSuggestion
-=over 4
-
(\@array) = &SearchSuggestion($user,$author,$title,$publishercode,$status,$suggestedbyme)
searches for a suggestion
@@ -87,14 +83,12 @@
* in the status field
* as parameter ( for example ASKED => 1, or REJECTED => 1) . This is for template & translation purposes.
-=back
-
=cut
sub SearchSuggestion {
my ($user,$author,$title,$publishercode,$status,$suggestedbyme)=@_;
my $dbh = C4::Context->dbh;
- my $query = qq|
+ my $query = "
SELECT suggestions.*,
U1.surname AS surnamesuggestedby,
U1.firstname AS firstnamesuggestedby,
@@ -103,7 +97,7 @@
FROM suggestions
LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
- WHERE 1=1 |;
+ WHERE 1=1 ";
my @sql_params;
if ($author) {
@@ -118,11 +112,6 @@
push @sql_params,"%".$publishercode."%";
$query .= " and publishercode like ?";
}
- if ($status) {
- push @sql_params,$status;
- $query .= " and status=?";
- }
-
if (C4::Context->preference("IndependantBranches")) {
my $userenv = C4::Context->userenv;
if ($userenv) {
@@ -132,6 +121,10 @@
}
}
}
+ if ($status) {
+ push @sql_params,$status;
+ $query .= " and status=?";
+ }
if ($suggestedbyme) {
unless ($suggestedbyme eq -1) {
push @sql_params,$user;
@@ -159,8 +152,6 @@
=head2 GetSuggestion
-=over 4
-
\%sth = &GetSuggestion($suggestionid)
this function get the detail of the suggestion $suggestionid (input arg)
@@ -168,17 +159,16 @@
return :
the result of the SQL query as a hash : $sth->fetchrow_hashref.
-=back
-
=cut
+
sub GetSuggestion {
my ($suggestionid) = @_;
my $dbh = C4::Context->dbh;
- my $query = qq|
+ my $query = "
SELECT *
FROM suggestions
WHERE suggestionid=?
- |;
+ ";
my $sth = $dbh->prepare($query);
$sth->execute($suggestionid);
return($sth->fetchrow_hashref);
@@ -186,8 +176,6 @@
=head2 GetSuggestionFromBiblionumber
-=over 4
-
$suggestionid = &GetSuggestionFromBiblionumber($dbh,$biblionumber)
Get a suggestion from it's biblionumber.
@@ -195,9 +183,8 @@
return :
the id of the suggestion which is related to the biblionumber given on input args.
-=back
-
=cut
+
sub GetSuggestionFromBiblionumber {
my ($dbh,$biblionumber) = @_;
my $query = qq|
@@ -211,19 +198,49 @@
return $suggestionid;
}
+=head2 GetSuggestionByStatus
-=head2 CountSuggestion
+$suggestions = &GetSuggestionByStatus($status)
+
+Get a suggestion from it's status
+
+return :
+all the suggestion with C<$status>
+
+=cut
-=over 4
+sub GetSuggestionByStatus {
+ my $status = shift;
+ my $dbh = C4::Context->dbh;
+ my $query = "SELECT suggestions.*,
+ U1.surname AS surnamesuggestedby,
+ U1.firstname AS firstnamesuggestedby,
+ U2.surname AS surnamemanagedby,
+ U2.firstname AS firstnamemanagedby
+ FROM suggestions
+ LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
+ LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
+ WHERE status = ?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($status);
+
+ my @results;
+ while(my $data = $sth->fetchrow_hashref){
+ $data->{date} = format_date($data->{date});
+ push @results,$data;
+ }
+ return \@results;
+}
+
+=head2 CountSuggestion
&CountSuggestion($status)
Count the number of suggestions with the status given on input argument.
the arg status can be :
-=over
-
-=over
+=over 2
=item * ASKED : asked by the user, not dealed by the librarian
@@ -235,14 +252,11 @@
=back
-=back
-
return :
the number of suggestion with this status.
-=back
-
=cut
+
sub CountSuggestion {
my ($status) = @_;
my $dbh = C4::Context->dbh;
@@ -286,33 +300,27 @@
=head2 NewSuggestion
-=over 4
-
&NewSuggestion($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber)
Insert a new suggestion on database with value given on input arg.
-=back
-
=cut
+
sub NewSuggestion {
- my ($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber) = @_;
+ my ($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber,$reason) = @_;
my $dbh = C4::Context->dbh;
-
my $query = qq |
INSERT INTO suggestions
(status,suggestedby,title,author,publishercode,note,copyrightdate,
- volumedesc,publicationyear,place,isbn,biblionumber)
- VALUES ('ASKED',?,?,?,?,?,?,?,?,?,?,?)
+ volumedesc,publicationyear,place,isbn,biblionumber,reason)
+ VALUES ('ASKED',?,?,?,?,?,?,?,?,?,?,?,?)
|;
my $sth = $dbh->prepare($query);
- $sth->execute($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber);
+ $sth->execute($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber,$reason);
}
=head2 ModStatus
-=over 4
-
&ModStatus($suggestionid,$status,$managedby,$biblionumber)
Modify the status (status can be 'ASKED', 'ACCEPTED', 'REJECTED', 'ORDERED')
@@ -320,70 +328,68 @@
Note that there is no function to modify a suggestion : only the status can be modified, thus the name of the function.
-=back
-
=cut
+
sub ModStatus {
- my ($suggestionid,$status,$managedby,$biblionumber,$input) = @_;
+ my ($suggestionid,$status,$managedby,$biblionumber,$reason) = @_;
my $dbh = C4::Context->dbh;
my $sth;
if ($managedby>0) {
if ($biblionumber) {
my $query = qq|
UPDATE suggestions
- SET status=?,managedby=?,biblionumber=?
+ SET status=?,managedby=?,biblionumber=?,reason=?
WHERE suggestionid=?
|;
$sth = $dbh->prepare($query);
- $sth->execute($status,$managedby,$biblionumber,$suggestionid);
+ $sth->execute($status,$managedby,$biblionumber,$reason,$suggestionid);
} else {
my $query = qq|
UPDATE suggestions
- SET status=?,managedby=?
+ SET status=?,managedby=?,reason=?
WHERE suggestionid=?
|;
$sth = $dbh->prepare($query);
- $sth->execute($status,$managedby,$suggestionid);
+ $sth->execute($status,$managedby,$reason,$suggestionid);
}
} else {
if ($biblionumber) {
my $query = qq|
UPDATE suggestions
- SET status=?,biblionumber=?
+ SET status=?,biblionumber=?,reason=?
WHERE suggestionid=?
|;
$sth = $dbh->prepare($query);
- $sth->execute($status,$biblionumber,$suggestionid);
+ $sth->execute($status,$biblionumber,$reason,$suggestionid);
}
else {
my $query = qq|
UPDATE suggestions
- SET status=?
+ SET status=?,reason=?
WHERE suggestionid=?
|;
$sth = $dbh->prepare($query);
- $sth->execute($status,$suggestionid);
+ $sth->execute($status,$reason,$suggestionid);
}
}
# check mail sending.
- my $queryMail = qq|
+ my $queryMail = "
SELECT suggestions.*,
boby.surname AS bysurname,
boby.firstname AS byfirstname,
- boby.emailaddress AS byemail,
+ boby.email AS byemail,
lib.surname AS libsurname,
lib.firstname AS libfirstname,
- lib.emailaddress AS libemail
+ lib.email AS libemail
FROM suggestions
LEFT JOIN borrowers AS boby ON boby.borrowernumber=suggestedby
LEFT JOIN borrowers AS lib ON lib.borrowernumber=managedby
WHERE suggestionid=?
- |;
+ ";
$sth = $dbh->prepare($queryMail);
$sth->execute($suggestionid);
my $emailinfo = $sth->fetchrow_hashref;
-if ($emailinfo->{byemail}){
- my $template = gettemplate("suggestion/mail_suggestion_$status.tmpl","intranet",$input);
+ my $template = gettemplate("suggestion/mail_suggestion_$status.tmpl","intranet");
$template->param(
byemail => $emailinfo->{byemail},
@@ -395,6 +401,7 @@
libfirstname => $emailinfo->{libfirstname},
byfirstname => $emailinfo->{byfirstname},
bysurname => $emailinfo->{bysurname},
+ reason => $emailinfo->{reason}
);
my %mail = (
To => $emailinfo->{byemail},
@@ -404,60 +411,64 @@
);
sendmail(%mail);
}
-}
=head2 ConnectSuggestionAndBiblio
-=over 4
&ConnectSuggestionAndBiblio($suggestionid,$biblionumber)
connect a suggestion to an existing biblio
-=back
-
=cut
+
sub ConnectSuggestionAndBiblio {
my ($suggestionid,$biblionumber) = @_;
my $dbh=C4::Context->dbh;
- my $query = qq |
+ my $query = "
UPDATE suggestions
SET biblionumber=?
WHERE suggestionid=?
- |;
+ ";
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber,$suggestionid);
}
=head2 DelSuggestion
-=over 4
-
&DelSuggestion($borrowernumber,$suggestionid)
Delete a suggestion. A borrower can delete a suggestion only if he is its owner.
-=back
-
=cut
sub DelSuggestion {
my ($borrowernumber,$suggestionid) = @_;
my $dbh = C4::Context->dbh;
# check that the suggestion comes from the suggestor
- my $query = qq |
+ my $query = "
SELECT suggestedby
FROM suggestions
WHERE suggestionid=?
- |;
+ ";
my $sth = $dbh->prepare($query);
$sth->execute($suggestionid);
my ($suggestedby) = $sth->fetchrow;
if ($suggestedby eq $borrowernumber) {
- my $queryDelete = qq|
+ my $queryDelete = "
DELETE FROM suggestions
WHERE suggestionid=?
- |;
+ ";
$sth = $dbh->prepare($queryDelete);
$sth->execute($suggestionid);
}
}
\ No newline at end of file
+
+1;
+__END__
+
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
+
Index: Z3950.pm
===================================================================
RCS file: /sources/koha/koha/C4/Z3950.pm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- Z3950.pm 6 Sep 2006 16:21:03 -0000 1.13
+++ Z3950.pm 9 Mar 2007 14:31:47 -0000 1.14
@@ -1,6 +1,6 @@
package C4::Z3950;
-# $Id: Z3950.pm,v 1.13 2006/09/06 16:21:03 tgarip1957 Exp $
+# $Id: Z3950.pm,v 1.14 2007/03/09 14:31:47 tipaul Exp $
# Routines for handling Z39.50 lookups
@@ -29,9 +29,9 @@
use strict;
# standard or CPAN modules used
+use DBI;
# Koha modules used
-use C4::Context;
use C4::Input;
use C4::Biblio;
@@ -42,7 +42,7 @@
use vars qw($VERSION @ISA @EXPORT);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision: 1.14 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
@@ -305,8 +305,11 @@
#--------------------------------------
# $Log: Z3950.pm,v $
-# Revision 1.13 2006/09/06 16:21:03 tgarip1957
-# Clean up before final commits
+# Revision 1.14 2007/03/09 14:31:47 tipaul
+# rel_3_0 moved to HEAD
+#
+# Revision 1.10.10.1 2006/12/22 15:09:54 toins
+# removing C4::Database;
#
# Revision 1.10 2003/10/01 15:08:14 tipaul
# fix fog bug #622 : processz3950queue fails
More information about the Koha-cvs
mailing list