[Koha-cvs] koha/intranet/modules/C4 AcademicInfo.pm Accoun... [rel_TG]
Tumer Garip
tgarip at neu.edu.tr
Sat Mar 10 02:35:35 CET 2007
CVSROOT: /sources/koha
Module name: koha
Branch: rel_TG
Changes by: Tumer Garip <tgarip1957> 07/03/10 01:35:34
Added files:
intranet/modules/C4: AcademicInfo.pm Accounts2.pm Acquisition.pm
Amazon.pm Auth.pm Auth_with_ldap.pm
AuthoritiesMarc.pm Biblio.pm Biblioadd.pm
BookShelves.pm Bookfund.pm Bookseller.pm
Boolean.pm Breeding.pm Context.pm
Date-new.pm Date.pm Format.pm Input.pm
Koha.pm Labels.pm Letters.pm Log.pm
Members.pm NewsChannels.pm Output.pm
Print.pm Record.pm Reserves2.pm Review.pm
SMS.pm Search.pm Serials-new.pm Serials.pm
Stats.pm Suggestions.pm Z3950.pm
Log message:
fresh files for rel_TG
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/AcademicInfo.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Accounts2.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Acquisition.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Amazon.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Auth.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Auth_with_ldap.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/AuthoritiesMarc.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Biblio.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Biblioadd.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/BookShelves.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Bookfund.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Bookseller.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Boolean.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Breeding.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Context.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Date-new.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Date.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Format.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Input.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Koha.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Labels.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Letters.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Log.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Members.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/NewsChannels.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Output.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Print.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Record.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Reserves2.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Review.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/SMS.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Search.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Serials-new.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Serials.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Stats.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Suggestions.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Z3950.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
Patches:
Index: AcademicInfo.pm
===================================================================
RCS file: AcademicInfo.pm
diff -N AcademicInfo.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ AcademicInfo.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,258 @@
+package C4::AcademicInfo;
+
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &academic_information
+ &get_careers
+ &get_career
+ &get_academic_info
+ &add_academic_info
+ &update_academic_info
+ &del_academic_info
+ &get_careers_by_institution
+ &get_educational_institution
+ &add_educational_institution
+ &update_educational_institution
+ &add_career
+ &update_career
+ &del_educational_institution
+ &del_career
+ &get_educational_institutions
+);
+
+
+sub academic_information {
+ my ($borrowernumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my @info;
+ my $query = "SELECT *
+ FROM
+ educational_institutions AS I
+ LEFT JOIN careers AS C ON C.id_institution = I.id_institution
+ LEFT JOIN academic_information AS A ON A.id_career = C.id_career
+ WHERE
+ borrowernumber = ?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber);
+ while (my $row = $sth->fetchrow_hashref) {
+ push @info, $row;
+ }
+ return (scalar(@info), @info);
+}
+
+sub get_academic_info {
+ my ($id_career, $borrowernumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM academic_information WHERE id_career = ? AND borrowernumber = ?");
+ $sth->execute($id_career, $borrowernumber);
+ if ($sth->rows) {
+ return ($sth->fetchrow_hashref);
+ } else {
+ return 0;
+ }
+}
+
+sub del_academic_info {
+ my ($id_career, $borrowernumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("DELETE FROM academic_information WHERE id_career = ? AND borrowernumber = ? ");
+ $sth->execute($id_career, $borrowernumber);
+ $sth->finish;
+ return 1;
+}
+
+sub add_academic_info {
+ my ($id_career, $borrowernumber, $student_number, $enter_year, $leave_year, $notes) = @_;
+ if (!get_academic_info($id_career, $borrowernumber)) {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO academic_information (id_career, borrowernumber, student_number, enter_year, leave_year, notes) VALUES (?,?,?,?,?,?)");
+ $sth->execute($id_career, $borrowernumber, $student_number, $enter_year, $leave_year, $notes);
+ $sth->finish;
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub update_academic_info {
+ my ($id_career, $borrowernumber, $student_number, $enter_year, $leave_year, $notes) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE academic_information SET student_number = ?, enter_year = ?, leave_year = ?, notes = ? WHERE id_career = ? AND borrowernumber = ?");
+ $sth->execute($student_number, $enter_year, $leave_year, $notes, $id_career, $borrowernumber);
+ $sth->finish;
+ return 1;
+}
+
+
+sub get_career {
+ my ($id_career) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM educational_institutions LEFT JOIN careers on educational_institutions.id_institution = careers.id_institution where id_career = ?");
+ $sth->execute($id_career);
+ my $info = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $info;
+}
+
+sub get_educational_institution {
+ my ($id_institution) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM educational_institutions WHERE id_institution = ? ORDER BY institution_name");
+ $sth->execute($id_institution);
+ my $info = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $info;
+}
+
+sub get_educational_institutions {
+ my $dbh = C4::Context->dbh;
+ my @results;
+ my $sth = $dbh->prepare("SELECT * FROM educational_institutions ORDER BY institution_name");
+ $sth->execute();
+ while (my $info = $sth->fetchrow_hashref) {
+ push @results, $info;
+ }
+ $sth->finish;
+ return @results;
+}
+
+sub get_careers {
+ my $dbh = C4::Context->dbh;
+ my @careers;
+ my $sth = $dbh->prepare("SELECT * FROM educational_institutions LEFT JOIN careers ON educational_institutions.id_institution = careers.id_institution ORDER BY career_name");
+ $sth->execute();
+ while (my $row = $sth->fetchrow_hashref) {
+ $row->{'full_description'} = $row->{'career_name'} . ' - ' . $row->{'institution_name'};
+ push @careers, $row;
+ }
+ return (scalar(@careers), @careers);
+}
+
+sub get_careers_by_institution {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM educational_institutions");
+ $sth->execute;
+
+ my @results;
+ while (my ($id, $name) = $sth->fetchrow) {
+ my %hash;
+ $hash{'id_institution'} = $id;
+ $hash{'institution_name'} = $name;
+ my @careers;
+ my $sth2 = $dbh->prepare("SELECT * FROM careers WHERE id_institution = ?");
+ $sth2->execute($hash{'id_institution'});
+ while (my $ca = $sth2->fetchrow_hashref) {
+ $ca->{'institution_name'} = $name;
+ push @careers, $ca;
+ }
+ $hash{'careers'} = \@careers;
+ push @results, \%hash;
+ }
+
+ return @results;
+}
+
+sub add_educational_institution {
+ my ($institution_name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO educational_institutions (institution_name) VALUES (?)");
+ $sth->execute($institution_name);
+ $sth->finish;
+ return 1;
+}
+
+sub update_educational_institution {
+ my ($id_institution, $institution_name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE educational_institutions SET institution_name = ? WHERE id_institution = ?");
+ $sth->execute($institution_name, $id_institution);
+ $sth->finish;
+ return 1;
+}
+
+sub del_educational_institution {
+ my ($id_institution) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM careers WHERE id_institution = ?");
+ $sth->execute($id_institution);
+ while (my $row = $sth->fetchrow_hashref) {
+ del_career($row->{'id_career'})
+ }
+ $sth->finish;
+ my $sth = $dbh->prepare("DELETE FROM educational_institutions WHERE id_institution = ?");
+ $sth->execute($id_institution);
+ $sth->finish;
+ return 1;
+}
+
+sub add_career {
+ my ($id_institution, $career_name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO careers (id_institution, career_name) VALUES (?,?)");
+ $sth->execute($id_institution, $career_name);
+ $sth->finish;
+ return 1;
+}
+
+sub update_career {
+ my ($id_career, $career_name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE careers SET career_name = ? WHERE id_career = ?");
+ $sth->execute($career_name, $id_career);
+ $sth->finish;
+ return 1;
+}
+
+sub del_career {
+ my ($id_career) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("DELETE FROM academic_information WHERE id_career = ?");
+ $sth->execute($id_career);
+ $sth->finish;
+ my $sth = $dbh->prepare("DELETE FROM careers WHERE id_career = ?");
+ $sth->execute($id_career);
+ $sth->finish;
+ return 1;
+}
+
+
+1;
+__END__
+=back
+
+=head1 AUTHOR
+
+Physics Library UNLP Argentina
+
+Carlos Sebastian Castañeda seba3c at yahoo.com.ar
+
+=cut
+
+
Index: Accounts2.pm
===================================================================
RCS file: Accounts2.pm
diff -N Accounts2.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Accounts2.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,659 @@
+package C4::Accounts2; #assumes C4/Accounts2
+
+
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Stats;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Accounts - Functions for dealing with Koha accounts
+
+=head1 SYNOPSIS
+
+ use C4::Accounts2;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with the monetary aspect of Koha,
+including looking up and modifying the amount of money owed by a
+patron.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&checkaccount &recordpayment &fixaccounts &makepayment &manualinvoice
+ &getnextacctno &manualcredit &calc_charges &createcharge
+
+ &dailyAccountBalance &addDailyAccountOp &getDailyAccountOp);
+
+=item checkaccount
+
+ $owed = &checkaccount($env, $borrowernumber, $dbh, $date);
+
+Looks up the total amount of money owed by a borrower (fines, etc.).
+
+C<$borrowernumber> specifies the borrower to look up.
+
+C<$dbh> is a DBI::db handle for the Koha database.
+
+C<$env> is ignored.
+
+=cut
+#'
+sub checkaccount {
+ #take borrower number
+ #check accounts and list amounts owing
+ my ($env,$bornumber,$dbh,$date)=@_;
+ my $select="SELECT SUM(amountoutstanding) AS total
+ FROM accountlines
+ WHERE borrowernumber = ?
+ AND amountoutstanding<>0";
+ my @bind = ($bornumber);
+ if ($date ne ''){
+ $select.=" AND date < ?";
+ push(@bind,$date);
+ }
+ # print $select;
+ my $sth=$dbh->prepare($select);
+ $sth->execute(@bind);
+ my $data=$sth->fetchrow_hashref;
+ my $total = $data->{'total'};
+ $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);
+ # }
+ #}
+ # pause();
+ return($total);
+}
+
+=item recordpayment
+
+ &recordpayment($env, $borrowernumber, $payment);
+
+Record payment by a patron. C<$borrowernumber> is the patron's
+borrower number. C<$payment> is a floating-point number, giving the
+amount that was paid. C<$env> is a reference-to-hash;
+C<$env-E<gt>{branchcode}> is the code of the branch where payment was
+made.
+
+Amounts owed are paid off oldest first. That is, if the patron has a
+$1 fine from Feb. 1, another $1 fine from Mar. 1, and makes a payment
+of $1.50, then the oldest fine will be paid off in full, and $0.50
+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 $dbh = C4::Context->dbh;
+ my $newamtos = 0;
+ my $accdata = "";
+ my $branch=$env->{'branchcode'};
+ my $amountleft = $data;
+ # begin transaction
+ my $nextaccntno = getnextacctno($env,$bornumber,$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);
+ # offset transactions
+ while (($accdata=$sth->fetchrow_hashref) and ($amountleft>0)){
+ if ($accdata->{'amountoutstanding'} < $amountleft) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ } else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+ my $thisacct = $accdata->{accountid};
+ my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
+ where accountid=?");
+ $usth->execute($newamtos,$thisacct);
+ $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->finish;
+# UpdateStats($env,$branch,'payment',$data,'','','',$bornumber);
+ $sth->finish;
+}
+
+=item makepayment
+
+ &makepayment($borrowernumber, $acctnumber, $amount, $branchcode);
+
+Records the fact that a patron has paid off the an amount he or
+she owes.
+
+C<$borrowernumber> is the patron's borrower number. C<$acctnumber> is
+the account that was credited. C<$amount> is the amount paid (this is
+only used to record the payment. 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
+ #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 $dbh = C4::Context->dbh;
+ # begin transaction
+ my $nextaccntno = getnextacctno($env,$bornumber,$dbh);
+ my $newamtos=0;
+ my $sth=$dbh->prepare("Select * from accountlines where borrowernumber=? and accountno=?");
+ $sth->execute($bornumber,$accountno);
+ my $data=$sth->fetchrow_hashref;
+ $sth->finish;
+
+ $dbh->do(<<EOT);
+ UPDATE accountlines
+ SET amountoutstanding = amountoutstanding-$amount
+ WHERE borrowernumber = $bornumber
+ AND accountno = $accountno
+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)
+EOT
+}
+
+ # FIXME - The second argument to &UpdateStats is supposed to be the
+ # branch code.
+# UpdateStats($env,'MAIN',$pay,$amount,'','','',$bornumber);
+ $sth->finish;
+ #check to see what accounttype
+ if ($data->{'accounttype'} eq 'Rep' || $data->{'accounttype'} eq 'L'){
+ returnlost($bornumber,$data->{'itemnumber'});
+ }
+}
+
+=item getnextacctno
+
+ $nextacct = &getnextacctno($env, $borrowernumber, $dbh);
+
+Returns the next unused account number for the patron with the given
+borrower number.
+
+C<$dbh> is a DBI::db handle to the Koha database.
+
+C<$env> is ignored.
+
+=cut
+#'
+# FIXME - Okay, so what does the above actually _mean_?
+sub getnextacctno {
+ my ($env,$bornumber,$dbh)=@_;
+ my $nextaccntno = 1;
+ my $sth = $dbh->prepare("select * from accountlines
+ where (borrowernumber = ?)
+ order by accountno desc");
+ $sth->execute($bornumber);
+ if (my $accdata=$sth->fetchrow_hashref){
+ $nextaccntno = $accdata->{'accountno'} + 1;
+ }
+ $sth->finish;
+ return($nextaccntno);
+}
+
+=item fixaccounts
+
+ &fixaccounts($borrowernumber, $accountnumber, $amount);
+
+=cut
+#'
+# FIXME - I don't know whether used
+sub fixaccounts {
+ my ($borrowernumber,$accountno,$amount)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Select * from accountlines where borrowernumber=?
+ and accountno=?");
+ $sth->execute($borrowernumber,$accountno);
+ my $data=$sth->fetchrow_hashref;
+ # FIXME - Error-checking
+ my $diff=$amount-$data->{'amount'};
+ my $outstanding=$data->{'amountoutstanding'}+$diff;
+ $sth->finish;
+
+ $dbh->do(<<EOT);
+ UPDATE accountlines
+ SET amount = '$amount',
+ amountoutstanding = '$outstanding'
+ WHERE borrowernumber = $borrowernumber
+ AND accountno = $accountno
+EOT
+ }
+
+
+sub returnlost{
+ my ($borrnum,$itemnum)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Update issues set returndate=now() where
+ borrowernumber=? and itemnumber=? and returndate is null");
+ $sth->execute($borrnum,$itemnum);
+ $sth->finish;
+}
+
+=item manualinvoice
+
+ &manualinvoice($borrowernumber, $description, $type,
+ $amount, $user);
+
+C<$borrowernumber> is the patron's borrower number.
+C<$description> is a description of the transaction.
+C<$type> may be one of C<CS>, C<CB>, C<CW>, C<CF>, C<CL>, C<N>, C<L>,
+or C<REF>.
+
+
+=cut
+#'
+
+sub manualinvoice{
+ my ($bornum,$desc,$type,$amount,$user)=@_;
+ my $dbh = C4::Context->dbh;
+ my $insert;
+ my %env;
+ my $accountno=getnextacctno('',$bornum,$dbh);
+ my $amountleft=$amount;
+
+
+ if ($type eq 'N'){
+ $desc.="New Card";
+ }
+
+ if ($type eq 'L' && $desc eq ''){
+ $desc="Lost Item";
+ }
+ if ($type eq 'REF'){
+ $desc="Cash refund";
+ }
+ $amountleft=refund('',$bornum,$amount);
+ my $sth=$dbh->prepare("INSERT INTO accountlines
+ (borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding)
+ VALUES (?, ?, now(), ?, ?, ?, ?)");
+ $sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft);
+
+}
+
+sub manualcredit{
+ my ($bornum,$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;
+
+ my $sth=$dbh->prepare("INSERT INTO accountlines
+ (borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding,offset)
+ VALUES (?, ?, now(), ?, ?, ?, ?,?)");
+ $sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft,$oldaccount);
+
+return ("0");
+} else {
+ return("1");
+}
+}
+# fixcredit
+sub fixcredit{
+ #here we update both the accountoffsets and the account lines
+ my ($dbh,$bornumber,$data,$accountid,$type,$user)=@_;
+ my $newamtos = 0;
+ my $accdata = "";
+ my $amountleft = $data;
+ my $env;
+ my $query="Select * from accountlines where accountid=? and amountoutstanding > 0";
+ my $sth=$dbh->prepare($query);
+$sth->execute($accountid);
+ $accdata=$sth->fetchrow_hashref;
+ $sth->finish;
+
+if ($accdata){
+ if ($accdata->{'amountoutstanding'} < $amountleft) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ } else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+ my $thisacct = $accdata->{accountid};
+ my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
+ where accountid=?");
+ $usth->execute($newamtos,$thisacct);
+ $usth->finish;
+
+ # begin transaction
+ # 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);
+# print $query;
+ # offset transactions
+ while (($accdata=$sth->fetchrow_hashref) and ($amountleft>0)){
+ if ($accdata->{'amountoutstanding'} < $amountleft) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ } else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+ my $thisacct = $accdata->{accountid};
+ my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
+ where accountid=?");
+ $usth->execute($newamtos,$thisacct);
+ $usth->finish;
+ }## while account
+ $sth->finish;
+
+ $amountleft*=-1;
+ return($amountleft,1,$accdata->{'accountno'});
+}else{
+return("",0);
+}
+}
+
+
+#
+sub refund{
+ #here we update both the accountoffsets and the account lines
+ my ($env,$bornumber,$data)=@_;
+ my $dbh = C4::Context->dbh;
+ my $newamtos = 0;
+ my $accdata = "";
+# my $branch=$env->{'branchcode'};
+ my $amountleft = $data *-1;
+
+ # begin transaction
+ # 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);
+# print $amountleft;
+ # offset transactions
+ while (($accdata=$sth->fetchrow_hashref) and ($amountleft<0)){
+ if ($accdata->{'amountoutstanding'} > $amountleft) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ } else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+# print $amountleft;
+ my $thisacct = $accdata->{accountid};
+ my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
+ where accountid=?");
+ $usth->execute($newamtos,$thisacct);
+ $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;
+ }
+
+ }
+}
+
+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);
+}
+
+=item calc_charges
+
+ ($charge, $item_type) = &calc_charges($env, $itemnumber, $borrowernumber);
+
+Calculate how much it would cost for a given patron to borrow a given
+item, including any applicable discounts.
+
+C<$env> is ignored.
+
+C<$itemnumber> is the item number of item the patron wishes to borrow.
+
+C<$borrowernumber> is the patron's borrower number.
+
+C<&calc_charges> returns two values: C<$charge> is the rental charge,
+and C<$item_type> is the code for the item's item type (e.g., C<VID>
+if it's a video).
+
+=cut
+
+sub calc_charges {
+ # calculate charges due
+ my ($env, $itemnumber, $bornum)=@_;
+ my $charge=0;
+ my $dbh = C4::Context->dbh;
+ my $sth= $dbh->prepare("select ctype from items where itemnumber=?");
+ $sth->execute($itemnumber);
+ my $itemtype=$sth->fetchrow;
+ $sth->finish;
+
+ my $sth1= $dbh->prepare("select rentalcharge from itemtypes where itemtypes.itemtype=?");
+ $sth1->execute($itemtype);
+
+ $charge = $sth1->fetchrow;
+ my $q2 = "select rentaldiscount from issuingrules,borrowers
+ where (borrowers.borrowernumber = ?)
+ and (borrowers.categorycode = issuingrules.categorycode)
+ and (issuingrules.itemtype = ?)";
+ my $sth2=$dbh->prepare($q2);
+ $sth2->execute($bornum,$itemtype);
+ if (my $data2=$sth2->fetchrow_hashref) {
+ my $discount = $data2->{'rentaldiscount'};
+ if ($discount eq 'NULL') {
+ $discount=0;
+ }
+ $charge = ($charge *(100 - $discount)) / 100;
+ # warn "discount is $discount";
+ }
+ $sth2->finish;
+
+ $sth1->finish;
+ return ($charge,$itemtype);
+}
+
+
+
+sub createcharge {
+
+ my ($env,$dbh,$itemnumber,$bornum,$charge) = @_;
+ my $nextaccntno = getnextacctno($env,$bornum,$dbh);
+ my $sth = $dbh->prepare(<<EOT);
+ INSERT INTO accountlines
+ (borrowernumber, itemnumber, accountno,
+ date, amount, description, accounttype,
+ amountoutstanding)
+ VALUES (?, ?, ?,
+ now(), ?, 'Rental', 'Rent',
+ ?)
+EOT
+ $sth->execute($bornum, $itemnumber, $nextaccntno, $charge, $charge);
+ $sth->finish;
+}
+
+1;
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+DBI(3)
+
+=cut
Index: Acquisition.pm
===================================================================
RCS file: Acquisition.pm
diff -N Acquisition.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Acquisition.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,973 @@
+package C4::Acquisition;
+
+# 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: Acquisition.pm,v 1.1.2.1 2007/03/10 01:35:33 tgarip1957 Exp $
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Date;
+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.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+# used in receiveorder subroutine
+# to provide library specific handling
+my $library_name = C4::Context->preference("LibraryName");
+
+=head1 NAME
+
+C4::Acquisition - Koha functions for dealing with orders and acquisitions
+
+=head1 SYNOPSIS
+
+use C4::Acquisition;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with acquisitions, managing book
+orders, basket and parcels.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &GetBasket &NewBasket &CloseBasket
+ &GetPendingOrders &GetOrder &GetOrders
+ &GetOrderNumber &GetLateOrders &NewOrder &DelOrder
+ &GetHistory
+ &ModOrder &ModReceiveOrder
+ &GetSingleOrder
+);
+
+
+=head2 FUNCTIONS ABOUT BASKETS
+
+=over 2
+
+=cut
+
+#------------------------------------------------------------#
+
+=head3 GetBasket
+
+=over 4
+
+$aqbasket = &GetBasket($basketnumber);
+
+get all basket informations in aqbasket for a given basket
+
+return :
+informations for a given basket returned as a hashref.
+
+=back
+
+=back
+
+=cut
+
+sub GetBasket {
+ my ($basketno) = shift;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT aqbasket.*,
+ concat(borrowers.firstname,' ',borrowers.surname) AS authorisedbyname,
+ borrowers.branchcode AS branch
+ FROM aqbasket
+ LEFT JOIN borrowers ON aqbasket.authorisedby=borrowers.borrowernumber
+ WHERE basketno=?
+ ";
+ my $sth=$dbh->prepare($query);
+ $sth->execute($basketno);
+ return ( $sth->fetchrow_hashref );
+}
+
+#------------------------------------------------------------#
+
+=head3 NewBasket
+
+=over 4
+
+$basket = &NewBasket();
+
+Create a new basket in aqbasket table
+
+=back
+
+=cut
+
+# FIXME : this function seems to be unused.
+
+sub NewBasket {
+ my ( $booksellerid, $authorisedby ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ INSERT INTO aqbasket
+ (creationdate,booksellerid,authorisedby)
+ VALUES (now(),'$booksellerid','$authorisedby')
+ ";
+ my $sth =
+ $dbh->do($query);
+
+#find & return basketno MYSQL dependant, but $dbh->last_insert_id always returns null :-(
+ my $basket = $dbh->{'mysql_insertid'};
+ return $basket;
+}
+
+#------------------------------------------------------------#
+
+=head3 CloseBasket
+
+=over 4
+
+&CloseBasket($basketno);
+
+close a basket (becomes unmodifiable,except for recieves)
+
+=back
+
+=cut
+
+sub CloseBasket {
+ my ($basketno) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqbasket
+ SET closedate=now()
+ WHERE basketno=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($basketno);
+}
+
+#------------------------------------------------------------#
+
+=back
+
+=head2 FUNCTIONS ABOUT ORDERS
+
+=over 2
+
+=cut
+
+#------------------------------------------------------------#
+
+=head3 GetPendingOrders
+
+=over 4
+
+$orders = &GetPendingOrders($booksellerid);
+
+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:
+
+=over 2
+
+=item C<authorizedby>
+
+=item C<entrydate>
+
+=item C<basketno>
+
+These give the value of the corresponding field in the aqorders table
+of the Koha database.
+
+=back
+
+=back
+
+Results are ordered from most to least recent.
+
+=cut
+
+sub GetPendingOrders {
+ my $supplierid = shift;
+ my $dbh = C4::Context->dbh;
+ my $strsth = "SELECT aqorders.*,aqbasket.*,borrowers.firstname,borrowers.surname
+ 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) ";
+
+ if ( C4::Context->preference("IndependantBranches") ) {
+ my $userenv = C4::Context->userenv;
+ if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
+ $strsth .=
+ " and (borrowers.branchcode = '"
+ . $userenv->{branch}
+ . "' or borrowers.branchcode ='')";
+ }
+ }
+ $strsth .= " group by aqbasket.basketno order by aqbasket.basketno";
+ my $sth = $dbh->prepare($strsth);
+ $sth->execute($supplierid);
+ my @results;
+ while (my $data = $sth->fetchrow_hashref ) {
+ push @results, $data ;
+ }
+ $sth->finish;
+ return \@results;
+}
+
+#------------------------------------------------------------#
+
+=head3 GetOrders
+
+=over 4
+
+ at orders = &GetOrders($basketnumber, $orderby);
+
+Looks up the non-cancelled orders (whether received or not) with the given basket
+number. If C<$booksellerID> is non-empty, only orders from that seller
+are returned.
+
+return :
+C<&basket> returns a two-element array. C<@orders> is an array of
+references-to-hash, whose keys are the fields from the aqorders,
+biblio, and biblioitems tables in the Koha database.
+
+=back
+
+=cut
+
+sub GetOrders {
+ my ( $basketno, $orderby ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query ="
+ SELECT aqorderbreakdown.*,
+ biblio.*,
+ aqorders.*
+ FROM aqorders,biblio
+ LEFT JOIN aqorderbreakdown ON
+ aqorders.ordernumber=aqorderbreakdown.ordernumber
+ WHERE basketno=?
+ AND biblio.biblionumber=aqorders.biblionumber
+ AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')
+ ";
+
+ $orderby = "biblio.title" 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;
+ }
+ $sth->finish;
+ 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
+
+=over 4
+
+$ordernumber = &GetOrderNumber($biblioitemnumber, $biblionumber);
+
+Looks up the ordernumber with the given biblionumber
+
+Returns the number of this order.
+
+=item C<$ordernumber> is the order number.
+
+=back
+
+=cut
+sub GetOrderNumber {
+ my ( $biblionumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT ordernumber
+ FROM aqorders
+ WHERE biblionumber=?
+
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblionumber );
+
+ return $sth->fetchrow;
+}
+
+#------------------------------------------------------------#
+
+=head3 GetOrder
+
+=over 4
+
+$order = &GetOrder($ordernumber);
+
+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
+aqorderbreakdown tables of the Koha database.
+
+=back
+
+=cut
+
+sub GetOrder {
+ my ($ordnum) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT *
+ FROM biblio,aqorders
+ LEFT JOIN aqorderbreakdown ON aqorders.ordernumber=aqorderbreakdown.ordernumber
+ WHERE aqorders.ordernumber=?
+ AND biblio.biblionumber=aqorders.biblionumber
+
+ ";
+ my $sth= $dbh->prepare($query);
+ $sth->execute($ordnum);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $data;
+}
+
+#------------------------------------------------------------#
+
+=head3 NewOrder
+
+=over 4
+
+ &NewOrder($basket, $biblionumber, $title, $quantity, $listprice,
+ $booksellerid, $who, $notes, $bookfund, $biblioitemnumber, $rrp,
+ $ecost, $gst, $budget, $unitprice, $subscription,
+ $booksellerinvoicenumber);
+
+Adds a new order to the database. Any argument that isn't described
+below is the new value of the field with the same name in the aqorders
+table of the Koha database.
+
+C<$ordnum> is a "minimum order number." After adding the new entry to
+the aqorders table, C<&neworder> finds the first entry in aqorders
+with order number greater than or equal to C<$ordnum>, and adds an
+entry to the aqorderbreakdown table, with the order number just found,
+and the book fund ID of the newly-added order.
+
+C<$budget> is effectively ignored.
+
+C<$subscription> may be either "yes", or anything else for "no".
+
+=back
+
+=cut
+
+sub NewOrder {
+ my (
+ $basketno, $biblionumber, $title, $quantity,
+ $listprice, $booksellerid, $authorisedby, $notes,
+ $bookfund, $rrp, $ecost,
+ $gst, $budget, $cost, $sub,
+ $purchaseorderno, $sort1, $sort2,$discount,$branch
+ )
+ = @_;
+
+ my $year = localtime->year() + 1900;
+ my $month = localtime->mon() + 1; # months starts at 0, add 1
+
+ if ( !$budget || $budget eq 'now' ) {
+ $budget = "now()";
+ }
+
+ if ( $sub eq 'yes' ) {
+ $sub = 1;
+ }
+ else {
+ $sub = 0;
+ }
+
+ # if $basket empty, it's also a new basket, create it
+ unless ($basketno) {
+ $basketno = NewBasket( $booksellerid, $authorisedby );
+ }
+
+ my $dbh = C4::Context->dbh;
+ 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() )
+ ";
+ my $sth = $dbh->prepare($query);
+
+ $sth->execute(
+ $biblionumber, $title, $basketno, $quantity, $listprice,
+ $notes, $rrp, $ecost, $gst,
+ $cost, $sub, $sort1, $sort2,$purchaseorderno,$discount
+ );
+ $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 (?,?,?)
+ ";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $ordnum, $bookfund,$branch );
+ $sth->finish;
+ return ( $basketno, $ordnum );
+}
+
+#------------------------------------------------------------#
+
+=head3 ModOrder
+
+=over 4
+
+&ModOrder($title, $ordernumber, $quantity, $listprice,
+ $biblionumber, $basketno, $supplier, $who, $notes,
+ $bookfundid, $bibitemnum, $rrp, $ecost, $gst, $budget,
+ $unitprice, $booksellerinvoicenumber);
+
+Modifies an existing order. Updates the order with order number
+C<$ordernumber> and biblionumber C<$biblionumber>. All other arguments
+update the fields with the same name in the aqorders table of the Koha
+database.
+
+Entries with order number C<$ordernumber> in the aqorderbreakdown
+table are also updated to the new book fund ID.
+
+=back
+
+=cut
+
+sub ModOrder {
+ my (
+ $title, $ordnum, $quantity, $listprice, $biblionumber,
+ $basketno, $supplier, $who, $notes, $bookfund,
+ $rrp, $ecost, $gst, $budget,
+ $cost, $invoice, $sort1, $sort2,$discount,$branch
+ )
+ = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqorders
+ SET title=?,
+ quantity=?,listprice=?,basketno=?,
+ rrp=?,ecost=?,unitprice=?,purchaseordernumber=?,gst=?,
+ notes=?,sort1=?, sort2=?,discount=?
+ 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
+ );
+ $sth->finish;
+ my $query = "
+ REPLACE aqorderbreakdown
+ SET ordernumber=?, bookfundid=?, branchcode=?
+ ";
+ $sth = $dbh->prepare($query);
+
+ $sth->execute( $ordnum,$bookfund, $branch );
+
+ $sth->finish;
+}
+
+#------------------------------------------------------------#
+
+
+
+
+#------------------------------------------------------------#
+
+=head3 ModReceiveOrder
+
+=over 4
+
+&ModReceiveOrder($biblionumber, $ordernumber, $quantityreceived, $user,
+ $unitprice, $booksellerinvoicenumber, $biblioitemnumber,
+ $freight, $bookfund, $rrp);
+
+Updates an order, to reflect the fact that it was received, at least
+in part. All arguments not mentioned below update the fields with the
+same name in the aqorders table of the Koha database.
+
+Updates the order with bibilionumber C<$biblionumber> and ordernumber
+C<$ordernumber>.
+
+
+=back
+
+=cut
+
+
+sub ModReceiveOrder {
+ my (
+ $biblionumber, $ordnum, $quantrec, $cost,
+ $invoiceno, $freight, $rrp, $listprice,$input
+ )
+ = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqorders
+ SET quantityreceived=quantityreceived+?,datereceived=now(),booksellerinvoicenumber=?,
+ unitprice=?,freight=?,rrp=?,listprice=?
+ WHERE biblionumber=? AND ordernumber=?
+ ";
+ my $sth = $dbh->prepare($query);
+ my $suggestionid = GetSuggestionFromBiblionumber( $dbh, $biblionumber );
+ if ($suggestionid) {
+ ModStatus( $suggestionid, 'AVAILABLE', '', $biblionumber,$input );
+ }
+ $sth->execute( $quantrec, $invoiceno, $cost, $freight, $rrp, $listprice, $biblionumber,
+ $ordnum );
+ $sth->finish;
+
+}
+
+
+#------------------------------------------------------------#
+
+=head3 DelOrder
+
+=over 4
+
+&DelOrder($biblionumber, $ordernumber);
+
+Cancel the order with the given order and biblio numbers. It does not
+delete any entries in the aqorders table, it merely marks them as
+cancelled.
+
+=back
+
+=cut
+
+sub DelOrder {
+ my ( $biblionumber, $ordnum,$user ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqorders
+ SET datecancellationprinted=now(), cancelledby=?
+ WHERE biblionumber=? AND ordernumber=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $user,$biblionumber, $ordnum );
+ $sth->finish;
+}
+
+
+=back
+
+=back
+
+=head2 FUNCTIONS ABOUT PARCELS
+
+=over 2
+
+=cut
+
+#------------------------------------------------------------#
+
+=head3 GetParcel
+
+=over 4
+
+ at results = &GetParcel($booksellerid, $code, $date);
+
+Looks up all of the received items from the supplier with the given
+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.
+
+C<@results> is sorted alphabetically by book title.
+
+=back
+
+=cut
+## This routine is not used will be cleaned
+sub GetParcel {
+
+ #gets all orders from a certain supplier, orders them alphabetically
+ my ( $supplierid, $invoice, $datereceived ) = @_;
+ my $dbh = C4::Context->dbh;
+ my @results = ();
+ $invoice .= '%' if $invoice; # add % if we search on a given invoice
+ my $strsth ="
+ SELECT authorisedby,
+ creationdate,
+ aqbasket.basketno,
+ closedate,surname,
+ firstname,
+ biblionumber,
+ aqorders.title,
+ aqorders.ordernumber,
+ aqorders.quantity,
+ aqorders.quantityreceived,
+ aqorders.unitprice,
+ aqorders.listprice,
+ aqorders.rrp,
+ aqorders.ecost
+ FROM aqorders,aqbasket
+ 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 "%";
+
+ if ( C4::Context->preference("IndependantBranches") ) {
+ my $userenv = C4::Context->userenv;
+ if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
+ $strsth .=
+ " and (borrowers.branchcode = '"
+ . $userenv->{branch}
+ . "' or borrowers.branchcode ='')";
+ }
+ }
+ $strsth .= " order by aqbasket.basketno";
+ ### parcelinformation : $strsth
+ my $sth = $dbh->prepare($strsth);
+ $sth->execute($supplierid);
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @results, $data ;
+ }
+ ### countparcelbiblio: $count
+ $sth->finish;
+
+ return @results;
+}
+
+#------------------------------------------------------------#
+
+=head3 GetParcels
+
+=over 4
+
+$results = &GetParcels($bookseller, $order, $code, $datefrom, $dateto);
+get a lists of parcels.
+
+* Input arg :
+
+=item $bookseller
+is the bookseller this function has to get parcels.
+
+=item $order
+To know on what criteria the results list has to be ordered.
+
+=item $code
+is the booksellerinvoicenumber.
+
+=item $datefrom & $dateto
+to know on what date this function has to filter its search.
+
+* return:
+a pointer on a hash list containing parcel informations as such :
+
+=item Creation date
+
+=item Last operation
+
+=item Number of biblio
+
+=item Number of items
+
+=back
+
+=cut
+### This routine is not used will be cleaned
+sub GetParcels {
+ my ($bookseller,$order, $code, $datefrom, $dateto) = @_;
+ my $dbh = C4::Context->dbh;
+ my $strsth ="
+ SELECT aqorders.booksellerinvoicenumber,
+ datereceived,
+ count(DISTINCT biblionumber) AS biblio,
+ sum(quantity) AS itemsexpected,
+ sum(quantityreceived) AS itemsreceived
+ FROM aqorders, aqbasket
+ WHERE aqbasket.basketno = aqorders.basketno
+ AND aqbasket.booksellerid = $bookseller and datereceived IS NOT NULL
+ ";
+
+ $strsth .= "and aqorders.booksellerinvoicenumber like \"$code%\" " if ($code);
+
+ $strsth .= "and datereceived >=" . $dbh->quote($datefrom) . " " if ($datefrom);
+
+ $strsth .= "and datereceived <=" . $dbh->quote($dateto) . " " if ($dateto);
+
+ $strsth .= "group by aqorders.booksellerinvoicenumber,datereceived ";
+ $strsth .= "order by $order " if ($order);
+ my $sth = $dbh->prepare($strsth);
+
+ $sth->execute;
+ my @results;
+
+ while ( my $data2 = $sth->fetchrow_hashref ) {
+ push @results, $data2;
+ }
+
+ $sth->finish;
+ return @results;
+}
+
+#------------------------------------------------------------#
+
+=head3 GetLateOrders
+
+=over 4
+
+ at results = &GetLateOrders;
+
+Searches for bookseller with late orders.
+
+return:
+the table of supplier with late issues. This table is full of hashref.
+
+=back
+
+=cut
+
+sub GetLateOrders {
+## requirse fixing for KOHA 3 API. Currently does not return publisher
+ my $delay = shift;
+ my $supplierid = shift;
+ my $branch = shift;
+
+ my $dbh = C4::Context->dbh;
+
+ #BEWARE, order of parenthesis and LEFT JOIN is important for speed
+ my $strsth;
+ my $dbdriver = C4::Context->config("db_scheme") || "mysql";
+
+ # warn " $dbdriver";
+ if ( $dbdriver eq "mysql" ) {
+ $strsth = "
+ SELECT aqbasket.basketno,
+ DATE(aqbasket.closedate) AS orderdate,
+ aqorders.quantity - IFNULL(aqorders.quantityreceived,0) AS quantity,
+ aqorders.rrp AS unitpricesupplier,
+ aqorders.ecost AS unitpricelib,
+ (aqorders.quantity - IFNULL(aqorders.quantityreceived,0)) * aqorders.rrp AS subtotal,
+ aqbookfund.bookfundname AS budget,
+ borrowers.branchcode AS branch,
+ aqbooksellers.name AS supplier,
+ aqorders.title,
+ biblio.author,
+
+ DATEDIFF(CURDATE( ),closedate) AS latesince
+ FROM ((
+ (aqorders LEFT JOIN biblio ON biblio.biblionumber = aqorders.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
+ WHERE aqorders.basketno = aqbasket.basketno
+ AND (closedate < DATE_SUB(CURDATE( ),INTERVAL $delay DAY))
+ AND ((datereceived = '' OR datereceived is null)
+ OR (aqorders.quantityreceived < aqorders.quantity) )
+ ";
+ $strsth .= " AND aqbasket.booksellerid = $supplierid " if ($supplierid);
+ $strsth .= " AND borrowers.branchcode like \'" . $branch . "\'"
+ if ($branch);
+ $strsth .=
+ " AND borrowers.branchcode like \'"
+ . C4::Context->userenv->{branch} . "\'"
+ if ( C4::Context->preference("IndependantBranches")
+ && C4::Context->userenv
+ && C4::Context->userenv->{flags} != 1 );
+ $strsth .=" HAVING quantity<>0
+ AND unitpricesupplier<>0
+ AND unitpricelib<>0
+ ORDER BY latesince,basketno,borrowers.branchcode, supplier
+ ";
+ }
+ else {
+ $strsth = "
+ SELECT aqbasket.basketno,
+ DATE(aqbasket.closedate) AS orderdate,
+ aqorders.quantity, aqorders.rrp AS unitpricesupplier,
+ aqorders.ecost as unitpricelib,
+ aqorders.quantity * aqorders.rrp AS subtotal
+ aqbookfund.bookfundname AS budget,
+ borrowers.branchcode AS branch,
+ aqbooksellers.name AS supplier,
+ biblio.title,
+ biblio.author,
+
+ (CURDATE - closedate) AS latesince
+ FROM((
+ (aqorders LEFT JOIN biblio on biblio.biblionumber = aqorders.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
+ WHERE aqorders.basketno = aqbasket.basketno
+ AND (closedate < (CURDATE -(INTERVAL $delay DAY))
+ AND ((datereceived = '' OR datereceived is null)
+ OR (aqorders.quantityreceived < aqorders.quantity) ) ";
+ $strsth .= " AND aqbasket.booksellerid = $supplierid " if ($supplierid);
+
+ $strsth .= " AND borrowers.branchcode like \'" . $branch . "\'" if ($branch);
+ $strsth .=" AND borrowers.branchcode like \'". C4::Context->userenv->{branch} . "\'"
+ if (C4::Context->preference("IndependantBranches") && C4::Context->userenv->{flags} != 1 );
+ $strsth .=" ORDER BY latesince,basketno,borrowers.branchcode, supplier";
+ }
+ my $sth = $dbh->prepare($strsth);
+ $sth->execute;
+ my @results;
+ my $hilighted = 1;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $data->{hilighted} = $hilighted if ( $hilighted > 0 );
+ $data->{orderdate} = format_date( $data->{orderdate} );
+ push @results, $data;
+ $hilighted = -$hilighted;
+ }
+ $sth->finish;
+ return @results;
+}
+
+#------------------------------------------------------------#
+
+=head3 GetHistory
+
+=over 4
+
+(\@order_loop, $total_qty, $total_price, $total_qtyreceived)=&GetHistory( $title, $author, $name, $from_placed_on, $to_placed_on )
+
+this function get the search history.
+
+=back
+
+=cut
+
+sub GetHistory {
+ my ( $title, $author, $name, $from_placed_on, $to_placed_on ) = @_;
+ my @order_loop;
+ my $total_qty = 0;
+ my $total_qtyreceived = 0;
+ my $total_price = 0;
+
+# don't run the query if there are no parameters (list would be too long for sure !)
+ if ( $title || $author || $name || $from_placed_on || $to_placed_on ) {
+ my $dbh = C4::Context->dbh;
+ my $query ="
+ SELECT
+ biblio.title,
+ biblio.author,
+ aqorders.basketno,
+ name,aqbasket.creationdate,
+ aqorders.datereceived,
+ aqorders.quantity,
+ aqorders.quantityreceived,
+ aqorders.ecost,
+ aqorders.ordernumber
+ FROM aqorders,aqbasket,aqbooksellers,biblio";
+
+ $query .= ",borrowers "
+ if ( C4::Context->preference("IndependantBranches") );
+
+ $query .="
+ WHERE aqorders.basketno=aqbasket.basketno
+ AND aqbasket.booksellerid=aqbooksellers.id
+ AND biblio.biblionumber=aqorders.biblionumber ";
+
+ $query .= " AND aqbasket.authorisedby=borrowers.borrowernumber"
+ if ( C4::Context->preference("IndependantBranches") );
+
+ $query .= " AND biblio.title LIKE " . $dbh->quote( "%" . $title . "%" )
+ if $title;
+
+ $query .=
+ " AND biblio.author LIKE " . $dbh->quote( "%" . $author . "%" )
+ if $author;
+
+ $query .= " AND name LIKE " . $dbh->quote( "%" . $name . "%" ) if $name;
+
+ $query .= " AND creationdate >" . $dbh->quote($from_placed_on)
+ if $from_placed_on;
+
+ $query .= " AND creationdate<" . $dbh->quote($to_placed_on)
+ if $to_placed_on;
+
+ if ( C4::Context->preference("IndependantBranches") ) {
+ my $userenv = C4::Context->userenv;
+ if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
+ $query .=
+ " AND (borrowers.branchcode = '"
+ . $userenv->{branch}
+ . "' OR borrowers.branchcode ='')";
+ }
+ }
+ $query .= " ORDER BY booksellerid";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my $cnt = 1;
+ while ( my $line = $sth->fetchrow_hashref ) {
+ $line->{count} = $cnt++;
+ $line->{toggle} = 1 if $cnt % 2;
+ push @order_loop, $line;
+ $line->{creationdate} = format_date( $line->{creationdate} );
+ $line->{datereceived} = format_date( $line->{datereceived} );
+ $total_qty += $line->{'quantity'};
+ $total_qtyreceived += $line->{'quantityreceived'};
+ $total_price += $line->{'quantity'} * $line->{'ecost'};
+ }
+ }
+ return \@order_loop, $total_qty, $total_price, $total_qtyreceived;
+}
+
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Amazon.pm
===================================================================
RCS file: Amazon.pm
diff -N Amazon.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Amazon.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,91 @@
+
+package C4::Amazon;
+# Copyright 2004-2005 Joshua Ferraro (jmf at kados dot org)
+#
+# 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
+#
+# This module dynamically pulls amazon content into Koha. It does not
+# store the data in Koha's database. You'll need to get a developer's key
+# as well as an associate's tag to use it.
+# FIXME: need to write up more docs.
+#
+# To use this module you need to do three things:
+# 1. get a dev key and associate tag from Amazon
+# 2. uncomment the Amazon stuff in opac-detail.pl
+# 3. add the template variables to opac-detail.tmpl
+# here's what's available:
+# ProductDescription
+# ImageUrlMedium
+# ListPrice
+# url
+# loop SimilarProducts (Product)
+# loop Reviews (rating, Summary)
+#
+use strict;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = 0.01;
+
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(
+ &get_amazon_details
+);
+
+sub get_amazon_details {
+
+my ( $isbn ) = @_;
+
+# insert your dev key here
+my $dev_key='neulibrary-20';
+$isbn=substr($isbn,0,9);
+# insert your associates tag here
+my $af_tag='0YGCZ5GV9ZNGGS7THDG2';
+
+my $asin=$isbn;
+
+# old way from command line: shift @ARGV or die "Usage:perl amazon_http.ol <asin>\n";
+
+#my $url = "http://xml.amazon.com/onca/xml3?t=" . $af_tag .
+# "&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 $content = get($url);
+if ($content){
+
+my $xmlsimple = XML::Simple->new();
+my $response = $xmlsimple->XMLin($content,
+ 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
Index: Auth.pm
===================================================================
RCS file: Auth.pm
diff -N Auth.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Auth.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,627 @@
+# -*- tab-width: 8 -*-
+# NOTE: This file uses 8-character tabs; do not change the tab size!
+
+package C4::Auth;
+
+# 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
+
+use strict;
+use Digest::MD5 qw(md5_base64);
+require Exporter;
+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 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);
+
+ at EXPORT = qw(
+&checkpw
+);
+=head1 NAME
+
+C4::Auth - Authenticates Koha users
+
+=head1 SYNOPSIS
+
+ use CGI;
+ use C4::Auth;
+
+ my $query = new CGI;
+
+ my ($template, $borrowernumber, $cookie)
+ = get_template_and_user({template_name => "opac-main.tmpl",
+ query => $query,
+ type => "opac",
+ authnotrequired => 1,
+ flagsrequired => {borrow => 1},
+ });
+
+ print $query->header(
+ -type => "text/html",
+ -charset=>"utf-8",
+ -cookie => $cookie
+ ), $template->output;
+
+
+=head1 DESCRIPTION
+
+ The main function of this module is to provide
+ authentification. However the get_template_and_user function has
+ been provided so that a users login information is passed along
+ automatically. This gets loaded into the template.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &checkauth
+ &get_template_and_user
+);
+
+=item get_template_and_user
+
+ my ($template, $borrowernumber, $cookie)
+ = get_template_and_user({template_name => "opac-main.tmpl",
+ query => $query,
+ type => "opac",
+ authnotrequired => 1,
+ flagsrequired => {borrow => 1},
+ });
+
+ This call passes the C<query>, C<flagsrequired> and C<authnotrequired>
+ to C<&checkauth> (in this module) to perform authentification.
+ See C<&checkauth> for an explanation of these parameters.
+
+ The C<template_name> is then used to find the correct template for
+ the page. The authenticated users details are loaded onto the
+ template in the HTML::Template LOOP variable C<USER_INFO>. Also the
+ C<sessionID> is passed to the template. This can be used in templates
+ if cookies are disabled. It needs to be put as and input to every
+ authenticated page.
+
+ More information on the C<gettemplate> sub can be found in the
+ Output.pm module.
+
+=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 $borrowernumber;
+ if ($user) {
+ $template->param(loggedinusername => $user);
+ $template->param(sessionID => $sessionID);
+
+ $borrowernumber = getborrowernumber($user);
+ 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},);
+
+ # 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->{permissions} == 1) {
+ $template->param(CAN_user_permission => 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->{reserveforself} == 1) {
+ $template->param(CAN_user_reserveforself => 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->{management} == 1) {
+ $template->param(CAN_user_management => 1);
+ $template->param(CAN_user_tools => 1); }
+
+ if ($flags && $flags->{tools} == 1) {
+ $template->param(CAN_user_tools => 1); }
+
+ }
+ if ($in->{'type'} eq "intranet") {
+ $template->param(
+ intranetcolorstylesheet => C4::Context->preference("intranetcolorstylesheet"),
+ intranetstylesheet => C4::Context->preference("intranetstylesheet"),
+ IntranetNav => C4::Context->preference("IntranetNav"),
+
+ );
+
+ }
+ else {
+ $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"),
+ );
+ }
+ $template->param(
+ TemplateEncoding => C4::Context->preference("TemplateEncoding"),
+ AmazonContent => C4::Context->preference("AmazonContent"),
+ LibraryName => C4::Context->preference("LibraryName"),
+ );
+ return ($template, $borrowernumber, $cookie);
+}
+
+
+=item checkauth
+
+ ($userid, $cookie, $sessionID) = &checkauth($query, $noauth, $flagsrequired, $type);
+
+Verifies that the user is authorized to run this script. If
+the user is authorized, a (userid, cookie, session-id, flags)
+quadruple is returned. If the user is not authorized but does
+not have the required privilege (see $flagsrequired below), it
+displays an error page and exits. Otherwise, it displays the
+login page and exits.
+
+Note that C<&checkauth> will return if and only if the user
+is authorized, so it should be called early on, before any
+unfinished operations (e.g., if you've opened a file, then
+C<&checkauth> won't close it for you).
+
+C<$query> is the CGI object for the script calling C<&checkauth>.
+
+The C<$noauth> argument is optional. If it is set, then no
+authorization is required for the script.
+
+C<&checkauth> fetches user and session information from C<$query> and
+ensures that the user is authorized to run scripts that require
+authorization.
+
+The C<$flagsrequired> argument specifies the required privileges
+the user must have if the username and password are correct.
+It should be specified as a reference-to-hash; keys in the hash
+should be the "flags" for the user, as specified in the Members
+intranet module. Any key specified must correspond to a "flag"
+in the userflags table. E.g., { circulate => 1 } would specify
+that the user must have the "circulate" privilege in order to
+proceed. To make sure that access control is correct, the
+C<$flagsrequired> parameter must be specified correctly.
+
+The C<$type> argument specifies whether the template should be
+retrieved from the opac or intranet directory tree. "opac" is
+assumed if it is not specified; however, if C<$type> is specified,
+"intranet" is assumed if it is not "opac".
+
+If C<$query> does not have a valid session ID associated with it
+(i.e., the user has not logged in) or if the session has expired,
+C<&checkauth> presents the user with a login page (from the point of
+view of the original script, C<&checkauth> does not return). Once the
+user has authenticated, C<&checkauth> restarts the original script
+(this time, C<&checkauth> returns).
+
+The login page is provided using a HTML::Template, which is set in the
+systempreferences table or at the top of this file. The variable C<$type>
+selects which template to use, either the opac or the intranet
+authentification template.
+
+C<&checkauth> returns a user ID, a cookie, and a session ID. The
+cookie should be sent back to the browser; it verifies that the user
+has authenticated.
+
+=cut
+
+
+
+sub checkauth {
+ my $query=shift;
+ # $authnotrequired will be set for scripts which will run without authentication
+ my $authnotrequired = shift;
+ my $flagsrequired = shift;
+ my $type = shift;
+ $type = 'opac' unless $type;
+
+ my $dbh = C4::Context->dbh;
+ my $timeout = C4::Context->preference('timeout');
+ $timeout = 600 unless $timeout;
+
+ my $template_name;
+ if ($type eq 'opac') {
+ $template_name = "opac-auth.tmpl";
+ } elsif ($type eq 'wap') {
+ $template_name = "wap-auth.tmpl";
+ }else {
+ $template_name = "auth.tmpl";
+ }
+
+ # state variables
+ my $loggedin = 0;
+ my %info;
+ my ($userid, $cookie, $sessionID, $flags,$envcookie);
+ my $logout = $query->param('logout.x');
+ if ($userid = $ENV{'REMOTE_USER'}) {
+ # Using Basic Authentication, no cookies required
+ $cookie=$query->cookie(-name => 'sessionID',
+ -value => '',
+ -expires => '');
+ $loggedin = 1;
+ } elsif ($sessionID=$query->cookie('sessionID')) {
+ C4::Context->_new_userenv($sessionID);
+ 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},
+ );
+ }
+ my ($ip , $lasttime);
+
+ ($userid, $ip, $lasttime) = $dbh->selectrow_array(
+ "SELECT userid,ip,lasttime FROM sessions WHERE sessionid=?",
+ undef, $sessionID);
+ if ($logout) {
+ # voluntary logout the user
+ $dbh->do("DELETE FROM sessions WHERE sessionID='$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;
+ close L;
+ }
+ if ($userid) {
+ if ($lasttime<time()-$timeout) {
+ # timed logout
+ $info{'timed_out'} = 1;
+ $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;
+ close L;
+ } 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);
+ 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'};
+ close L;
+ } 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);
+ if ($flags) {
+ $loggedin = 1;
+ } else {
+ $info{'nopermission'} = 1;
+ }
+ }
+ }
+ }
+ unless ($userid) {
+ $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);
+ 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()));
+ open L, ">>/tmp/sessionlog";
+ 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',
+ -value => $sessionID,
+ -expires => '');
+ if ($flags = haspermission($dbh, $userid, $flagsrequired)) {
+ $loggedin = 1;
+ } 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=?");
+ $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=?");
+ $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){
+ $sth->execute($userid);
+ ($bornum,$firstname,$surname,$userflags,$branchcode, $branchname, $emailaddress) = $sth->fetchrow if ($sth->rows);
+ }
+# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
+ }
+ my $hash = C4::Context::set_userenv(
+ $bornum,
+ $userid,
+ $cardnumber,
+ $firstname,
+ $surname,
+ $branchcode,
+ $branchname,
+ $userflags,
+ $emailaddress,
+ );
+# warn "$cardnumber,$bornum,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress";
+ $envcookie=$query->cookie(-name => 'userenv',
+ -value => $hash,
+ -expires => '');
+ } elsif ($return == 2) {
+ #We suppose the user is the superlibrarian
+ my $hash = C4::Context::set_userenv(
+ 0,0,
+ C4::Context->config('user'),
+ C4::Context->config('user'),
+ C4::Context->config('user'),
+ "","",1,C4::Context->preference('KohaAdminEmailAddress')
+ );
+ $envcookie=$query->cookie(-name => 'userenv',
+ -value => $hash,
+ -expires => '');
+ }
+ } else {
+ if ($userid) {
+ $info{'invalid_username_or_password'} = 1;
+ C4::Context->_unset_userenv($sessionID);
+ }
+ }
+ }
+ my $insecure = C4::Context->boolean_preference('insecure');
+ # finished authentification, now respond
+ if ($loggedin || $authnotrequired || (defined($insecure) && $insecure)) {
+ # successful login
+ unless ($cookie) {
+ $cookie=$query->cookie(-name => 'sessionID',
+ -value => '',
+ -expires => '');
+ }
+ 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 $value = $query->param($name);
+ push @inputs, {name => $name , value => $value};
+ }
+
+ my $template = gettemplate($template_name, $type,$query);
+ $template->param(INPUTS => \@inputs,
+ intranetcolorstylesheet => C4::Context->preference("intranetcolorstylesheet"),
+ intranetstylesheet => C4::Context->preference("intranetstylesheet"),
+ IntranetNav => C4::Context->preference("IntranetNav"),
+ opacnav => C4::Context->preference("OpacNav"),
+ TemplateEncoding => C4::Context->preference("TemplateEncoding"),
+
+ );
+ $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',
+ -value => $sessionID,
+ -expires => '');
+
+output_html_with_http_headers($query, $cookie, $template->output());
+ exit;
+}
+
+
+
+
+sub checkpw {
+
+ my ($dbh, $userid, $password) = @_;
+# 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;
+ }
+ }
+ $sth=$dbh->prepare("select password from borrowers where cardnumber=?");
+ $sth->execute($userid);
+ if ($sth->rows) {
+ my ($md5password) = $sth->fetchrow;
+ if (md5_base64($password) eq $md5password) {
+ return 1,$userid;
+ }
+ }
+ if ($userid eq C4::Context->config('user') && $password eq C4::Context->config('pass')) {
+ # Koha superuser account
+ 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,
+ return 2;
+ }
+ return 0;
+}
+
+sub getuserflags {
+ my $cardnumber=shift;
+ my $dbh=shift;
+ my $userflags;
+ 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->execute;
+ 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=?");
+ $sth->execute($userid);
+ my ($cardnumber) = $sth->fetchrow;
+ ($cardnumber) || ($cardnumber=$userid);
+ my $flags=getuserflags($cardnumber,$dbh);
+ my $configfile;
+ if ($userid eq C4::Context->config('user')) {
+ # Super User Account from /etc/koha.conf
+ $flags->{'superlibrarian'}=1;
+ }
+ if ($userid eq 'demo' && C4::Context->config('demo')) {
+ # Demo user that can do "anything" (demo=1 in /etc/koha.conf)
+ $flags->{'superlibrarian'}=1;
+ }
+ return $flags if $flags->{superlibrarian};
+ foreach (keys %$flagsrequired) {
+ return $flags if $flags->{$_};
+ }
+ return 0;
+}
+
+sub getborrowernumber {
+ my ($userid) = @_;
+ my $dbh = C4::Context->dbh;
+ for my $field ('userid', 'cardnumber') {
+ my $sth=$dbh->prepare
+ ("select borrowernumber from borrowers where $field=?");
+ $sth->execute($userid);
+ if ($sth->rows) {
+ my ($bnumber) = $sth->fetchrow;
+ return $bnumber;
+ }
+ }
+ return 0;
+}
+1;
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+CGI(3)
+
+C4::Output(3)
+
+Digest::MD5(3)
+
+=cut
Index: Auth_with_ldap.pm
===================================================================
RCS file: Auth_with_ldap.pm
diff -N Auth_with_ldap.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Auth_with_ldap.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,688 @@
+# -*- tab-width: 8 -*-
+# NOTE: This file uses 8-character tabs; do not change the tab size!
+
+package C4::Auth;
+
+# 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
+
+use strict;
+use Digest::MD5 qw(md5_base64);
+
+require Exporter;
+use C4::Context;
+use C4::Output; # to get the template
+use C4::Interface::CGI::Output;
+use C4::Circulation::Circ2; # getpatroninformation
+use C4::Members;
+# 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;
+
+=head1 NAME
+
+C4::Auth - Authenticates Koha users
+
+=head1 SYNOPSIS
+
+ use CGI;
+ use C4::Auth;
+
+ my $query = new CGI;
+
+ my ($template, $borrowernumber, $cookie)
+ = get_template_and_user({template_name => "opac-main.tmpl",
+ query => $query,
+ type => "opac",
+ authnotrequired => 1,
+ flagsrequired => {borrow => 1},
+ });
+
+ print $query->header(
+ -type => guesstype($template->output),
+ -cookie => $cookie
+ ), $template->output;
+
+
+=head1 DESCRIPTION
+
+ The main function of this module is to provide
+ authentification. However the get_template_and_user function has
+ been provided so that a users login information is passed along
+ automatically. This gets loaded into the template.
+
+=head1 LDAP specific
+
+ This module is specific to LDAP authentification. It requires Net::LDAP package and a working LDAP server.
+ To use it :
+ * move initial Auth.pm elsewhere
+ * Search the string LOCAL
+ * modify the code between LOCAL and /LOCAL to fit your LDAP server parameters & fields
+ * rename this module to Auth.pm
+ That should be enough.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &checkauth
+ &get_template_and_user
+);
+
+=item get_template_and_user
+
+ my ($template, $borrowernumber, $cookie)
+ = get_template_and_user({template_name => "opac-main.tmpl",
+ query => $query,
+ type => "opac",
+ authnotrequired => 1,
+ flagsrequired => {borrow => 1},
+ });
+
+ This call passes the C<query>, C<flagsrequired> and C<authnotrequired>
+ to C<&checkauth> (in this module) to perform authentification.
+ See C<&checkauth> for an explanation of these parameters.
+
+ The C<template_name> is then used to find the correct template for
+ the page. The authenticated users details are loaded onto the
+ template in the HTML::Template LOOP variable C<USER_INFO>. Also the
+ C<sessionID> is passed to the template. This can be used in templates
+ if cookies are disabled. It needs to be put as and input to every
+ authenticated page.
+
+ More information on the C<gettemplate> sub can be found in the
+ Output.pm module.
+
+=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 $borrowernumber;
+ if ($user) {
+ $template->param(loggedinusername => $user);
+ $template->param(sessionID => $sessionID);
+
+ $borrowernumber = getborrowernumber($user);
+ my ($borr, $alternativeflags) = getpatroninformation(undef, $borrowernumber);
+ my @bordat;
+ $bordat[0] = $borr;
+ $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->{permissions} == 1) {
+ $template->param(CAN_user_permission => 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->{reserveforself} == 1) {
+ $template->param(CAN_user_reserveforself => 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->{management} == 1) {
+ $template->param(CAN_user_management => 1);
+ $template->param(CAN_user_tools => 1); }
+
+ if ($flags && $flags->{tools} == 1) {
+ $template->param(CAN_user_tools => 1); }
+ }
+ $template->param(
+ LibraryName => C4::Context->preference("LibraryName"),
+ );
+ return ($template, $borrowernumber, $cookie);
+}
+
+
+=item checkauth
+
+ ($userid, $cookie, $sessionID) = &checkauth($query, $noauth, $flagsrequired, $type);
+
+Verifies that the user is authorized to run this script. If
+the user is authorized, a (userid, cookie, session-id, flags)
+quadruple is returned. If the user is not authorized but does
+not have the required privilege (see $flagsrequired below), it
+displays an error page and exits. Otherwise, it displays the
+login page and exits.
+
+Note that C<&checkauth> will return if and only if the user
+is authorized, so it should be called early on, before any
+unfinished operations (e.g., if you've opened a file, then
+C<&checkauth> won't close it for you).
+
+C<$query> is the CGI object for the script calling C<&checkauth>.
+
+The C<$noauth> argument is optional. If it is set, then no
+authorization is required for the script.
+
+C<&checkauth> fetches user and session information from C<$query> and
+ensures that the user is authorized to run scripts that require
+authorization.
+
+The C<$flagsrequired> argument specifies the required privileges
+the user must have if the username and password are correct.
+It should be specified as a reference-to-hash; keys in the hash
+should be the "flags" for the user, as specified in the Members
+intranet module. Any key specified must correspond to a "flag"
+in the userflags table. E.g., { circulate => 1 } would specify
+that the user must have the "circulate" privilege in order to
+proceed. To make sure that access control is correct, the
+C<$flagsrequired> parameter must be specified correctly.
+
+The C<$type> argument specifies whether the template should be
+retrieved from the opac or intranet directory tree. "opac" is
+assumed if it is not specified; however, if C<$type> is specified,
+"intranet" is assumed if it is not "opac".
+
+If C<$query> does not have a valid session ID associated with it
+(i.e., the user has not logged in) or if the session has expired,
+C<&checkauth> presents the user with a login page (from the point of
+view of the original script, C<&checkauth> does not return). Once the
+user has authenticated, C<&checkauth> restarts the original script
+(this time, C<&checkauth> returns).
+
+The login page is provided using a HTML::Template, which is set in the
+systempreferences table or at the top of this file. The variable C<$type>
+selects which template to use, either the opac or the intranet
+authentification template.
+
+C<&checkauth> returns a user ID, a cookie, and a session ID. The
+cookie should be sent back to the browser; it verifies that the user
+has authenticated.
+
+=cut
+
+
+
+sub checkauth {
+ my $query=shift;
+ # $authnotrequired will be set for scripts which will run without authentication
+ my $authnotrequired = shift;
+ my $flagsrequired = shift;
+ my $type = shift;
+ $type = 'opac' unless $type;
+
+ my $dbh = C4::Context->dbh;
+ my $timeout = C4::Context->preference('timeout');
+ $timeout = 600 unless $timeout;
+
+ my $template_name;
+ if ($type eq 'opac') {
+ $template_name = "opac-auth.tmpl";
+ } else {
+ $template_name = "auth.tmpl";
+ }
+
+ # state variables
+ my $loggedin = 0;
+ my %info;
+ my ($userid, $cookie, $sessionID, $flags,$envcookie);
+ my $logout = $query->param('logout.x');
+ if ($userid = $ENV{'REMOTE_USER'}) {
+ # Using Basic Authentication, no cookies required
+ $cookie=$query->cookie(-name => 'sessionID',
+ -value => '',
+ -expires => '');
+ $loggedin = 1;
+ } elsif ($sessionID=$query->cookie('sessionID')) {
+ C4::Context->_new_userenv($sessionID);
+ 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},
+ );
+ }
+ my ($ip , $lasttime);
+ ($userid, $ip, $lasttime) = $dbh->selectrow_array(
+ "SELECT userid,ip,lasttime FROM sessions WHERE sessionid=?",
+ undef, $sessionID);
+ if ($logout) {
+ # voluntary logout the user
+ $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;
+ close L;
+ }
+ if ($userid) {
+ if ($lasttime<time()-$timeout) {
+ # timed logout
+ $info{'timed_out'} = 1;
+ $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;
+ close L;
+ } 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);
+ 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'};
+ close L;
+ } 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);
+ if ($flags) {
+ $loggedin = 1;
+ } else {
+ $info{'nopermission'} = 1;
+ }
+ }
+ }
+ }
+ unless ($userid) {
+ $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);
+ 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()));
+ open L, ">>/tmp/sessionlog";
+ 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',
+ -value => $sessionID,
+ -expires => '');
+ if ($flags = haspermission($dbh, $userid, $flagsrequired)) {
+ $loggedin = 1;
+ } 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=?");
+ $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=?");
+ $sth->execute($cardnumber);
+ ($bornum,$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);
+ }
+ }
+ my $hash = C4::Context::set_userenv(
+ $bornum,
+ $userid,
+ $cardnumber,
+ $firstname,
+ $surname,
+ $branchcode,
+ $userflags,
+ $emailaddress,
+ );
+ $envcookie=$query->cookie(-name => 'userenv',
+ -value => $hash,
+ -expires => '');
+ } elsif ($return == 2) {
+ #We suppose the user is the superlibrarian
+ my $hash = C4::Context::set_userenv(
+ 0,0,
+ C4::Context->config('user'),
+ C4::Context->config('user'),
+ C4::Context->config('user'),
+ "",1,C4::Context->preference('KohaAdminEmailAddress')
+ );
+ $envcookie=$query->cookie(-name => 'userenv',
+ -value => $hash,
+ -expires => '');
+ }
+ } else {
+ if ($userid) {
+ $info{'invalid_username_or_password'} = 1;
+ C4::Context->_unset_userenv($sessionID);
+ }
+ }
+ }
+ my $insecure = C4::Context->boolean_preference('insecure');
+ # finished authentification, now respond
+ if ($loggedin || $authnotrequired || (defined($insecure) && $insecure)) {
+ # successful login
+ unless ($cookie) {
+ $cookie=$query->cookie(-name => 'sessionID',
+ -value => '',
+ -expires => '');
+ }
+ 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 $value = $query->param($name);
+ 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',
+ -value => $sessionID,
+ -expires => '');
+ print $query->header(
+ -type => guesstype($template->output),
+ -cookie => $cookie
+ ), $template->output;
+ exit;
+}
+
+
+
+# this checkpw is a LDAP based one
+# it connects to LDAP (anonymous)
+# it retrieve $userid a-login
+# then compare $password with a-weak
+# then get the LDAP entry
+# 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')) {
+ # Koha superuser account
+ return 2;
+ }
+ ##################################################
+ ### LOCAL
+ ### Change the code below to match your own LDAP server.
+ ##################################################
+ # 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 );
+
+ # do an anonymous bind
+ 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)",
+ );
+ 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 );
+ ## HACK LMK
+ ## ligne originale
+ # if( $cmpmesg -> code != 6 ) {
+ 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 $key;
+ foreach my $k ( @$x) {
+ foreach my $k2 (keys %$k) {
+ if ($k2 eq 'type') {
+ $key = $$k{$k2};
+ } else {
+ my $a = @$k{$k2};
+ foreach my $k3 (@$a) {
+ $memberhash{$key} .= $k3." ";
+ }
+ }
+ }
+ }
+ #
+ # BUILD %borrower to CREATE or MODIFY BORROWER
+ # change $memberhash{'xxx'} to fit your ldap structure.
+ # check twice that mandatory fields are correctly filled
+ #
+ my %borrower;
+ $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{city} = " "; # MANDATORY FIELD
+ $borrower{phone} = " "; # MANDATORY FIELD
+ $borrower{branchcode} = $memberhash{branch}; # MANDATORY FIELD
+ $borrower{emailaddress} = $memberhash{mail};
+ $borrower{categorycode} = $memberhash{employeeType};
+ ##################################################
+ ### /LOCAL
+ ### 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=?");
+ $sth->execute($userid);
+ 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 {
+ # it does not exists, 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->execute($userid);
+ 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=?");
+ $sth->execute($userid);
+ 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->execute($userid);
+ if ($sth->rows) {
+ my ($md5password) = $sth->fetchrow;
+ if (md5_base64($password) eq $md5password) {
+ return 1,$userid;
+ }
+ }
+ return 0;
+}
+
+sub getuserflags {
+ my $cardnumber=shift;
+ my $dbh=shift;
+ my $userflags;
+ 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->execute;
+ 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=?");
+ $sth->execute($userid);
+ my ($cardnumber) = $sth->fetchrow;
+ ($cardnumber) || ($cardnumber=$userid);
+ my $flags=getuserflags($cardnumber,$dbh);
+ my $configfile;
+ if ($userid eq C4::Context->config('user')) {
+ # Super User Account from /etc/koha.conf
+ $flags->{'superlibrarian'}=1;
+ }
+ if ($userid eq 'demo' && C4::Context->config('demo')) {
+ # Demo user that can do "anything" (demo=1 in /etc/koha.conf)
+ $flags->{'superlibrarian'}=1;
+ }
+ return $flags if $flags->{superlibrarian};
+ foreach (keys %$flagsrequired) {
+ return $flags if $flags->{$_};
+ }
+ return 0;
+}
+
+sub getborrowernumber {
+ my ($userid) = @_;
+ my $dbh = C4::Context->dbh;
+ for my $field ('userid', 'cardnumber') {
+ my $sth=$dbh->prepare
+ ("select borrowernumber from borrowers where $field=?");
+ $sth->execute($userid);
+ if ($sth->rows) {
+ my ($bnumber) = $sth->fetchrow;
+ return $bnumber;
+ }
+ }
+ return 0;
+}
+
+1;
+__END__
+
+=back
+
+=head1 SEE ALSO
+
+CGI(3)
+
+C4::Output(3)
+
+Digest::MD5(3)
+
+=cut
Index: AuthoritiesMarc.pm
===================================================================
RCS file: AuthoritiesMarc.pm
diff -N AuthoritiesMarc.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ AuthoritiesMarc.pm 10 Mar 2007 01:35:33 -0000 1.1.2.1
@@ -0,0 +1,906 @@
+package C4::AuthoritiesMarc;
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Koha;
+use Encode;
+use C4::Biblio;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &AUTHgettagslib
+ &AUTHfindsubfield
+ &AUTHfind_authtypecode
+ &AUTHaddauthority
+ &AUTHmodauthority
+ &AUTHdelauthority
+ &AUTHaddsubfield
+
+ &AUTHfind_marc_from_kohafield
+ &AUTHgetauth_type
+ &AUTHcount_usage
+ &getsummary
+ &authoritysearch
+ &XMLgetauthority
+ &XMLgetauthorityhash
+ &XML_readline_withtags
+ &merge
+ &FindDuplicateauth
+ &ZEBRAdelauthority
+ );
+
+sub AUTHfind_marc_from_kohafield {
+ my ( $dbh, $kohafield,$authtypecode ) = @_;
+ return 0, 0 unless $kohafield;
+$authtypecode="" unless $authtypecode;
+my $marcfromkohafield;
+ 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 $query;
+ my $attr;
+ my $server;
+ my $mainentrytag;
+ ##first set the authtype search and may be multiple authorities( linked 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
+ push @authtypecode ,$auth;
+ $n++;
+ }
+ if ($n>1){
+ $query= "\@or ".$query;
+ }
+
+ my $dosearch;
+ my $and;
+ 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")." ";
+ }else{
+ ($attr) =MARCfind_attr_from_kohafield("allentry")." ";
+ }
+ if (@$operator[$i] eq 'phrase') {
+ $attr.=" \@attr 4=1 \@attr 5=100 \@attr 6=3 ";##Phrase, No truncation,all of subfield field must match
+
+ } else {
+
+ $attr .=" \@attr 4=6 \@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;
+
+$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
+
+
+my $oAResult;
+ $oAResult= $oAuth[0]->search_pqf($query) ;
+while (($i = ZOOM::event(\@oAuth)) != 0) {
+ my $ev = $oAuth[$i-1]->last_event();
+# warn("Authority ", $i-1, ": event $ev (", ZOOM::event_str($ev), ")\n");
+ last if $ev == ZOOM::Event::ZEND;
+}
+ my($error, $errmsg, $addinfo, $diagset) = $oAuth[0]->error_x();
+ if ($error) {
+ warn "oAuth error: $errmsg ($error) $addinfo $diagset\n";
+ goto NOLUCK;
+ }
+
+
+my $nbresults;
+ $nbresults=$oAResult->size();
+my $nremains=$nbresults;
+ 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;
+ $newline{summary} = $summary;
+ $newline{authid} = $authid;
+ $newline{linkid} = $linkid[0];
+ $newline{even} = $counter % 2;
+ $counter++;
+ push @finalresult, \%newline;
+ }## while counter
+
+
+for (my $z=0; $z<($nbresults<$length?$nbresults:$length); $z++){
+ $finalresult[$z]{used}=AUTHcount_usage($finalresult[$z]{authid});
+
+ }# all $z's
+
+
+}## if nbresult
+NOLUCK:
+$oAResult->destroy();
+$oAuth[0]->destroy();
+
+ return (\@finalresult, $nbresults);
+}
+
+
+
+sub AUTHcount_usage {
+ my ($authid) = @_;
+### try ZOOM search here
+my @oConnection;
+$oConnection[0]=C4::Context->Zconn("biblioserver");
+my $query;
+my ($attrfield)=MARCfind_attr_from_kohafield("authid");
+$query= $attrfield." ".$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);
+}
+
+
+
+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 AUTHgettagslib {
+ my ($dbh,$forlibrarian,$authtypecode)= @_;
+ $authtypecode="" unless $authtypecode;
+ my $sth;
+ my $libfield = ($forlibrarian eq 1)? 'liblibrarian' : 'libopac';
+
+
+ # check that authority exists
+ $sth=$dbh->prepare("select count(*) from auth_tag_structure where authtypecode=?");
+ $sth->execute($authtypecode);
+ my ($total) = $sth->fetchrow;
+ $authtypecode="" unless ($total >0);
+ $sth= $dbh->prepare(
+"select tagfield,liblibrarian,libopac,mandatory,repeatable from auth_tag_structure where authtypecode=? order by tagfield"
+ );
+
+$sth->execute($authtypecode);
+ 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,seealso,hidden,isurl,link 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;
+ my $hidden;
+ my $isurl;
+ my $link;
+
+ 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;
+}
+
+sub AUTHaddauthority {
+# pass the XML hash to this function, and it will create the records in the authority table
+ my ($dbh,$record,$authid,$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;
+ }
+
+##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);
+ $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);
+}
+
+sub AUTHaddlink{
+my ($dbh,$linkid,$authid)=@_;
+my $record=XMLgetauthorityhash($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);
+ $sth->finish;
+ $dbh->do("unlock tables");
+ ZEBRAop($dbh,$linkid,'specialUpdate',"authorityserver");
+}
+
+
+
+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=? " );
+ $sth->execute($authid);
+ my ($marcxml)=$sth->fetchrow;
+ $marcxml=Encode::decode('utf8',$marcxml);
+ 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 AUTHgetauth_type {
+ my ($authtypecode) = @_;
+ my $dbh=C4::Context->dbh;
+ my $sth=$dbh->prepare("select * from auth_types where authtypecode=?");
+ $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
+ if ($oldrecord eq $record) {
+ return $authid;
+ }
+##
+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){
+ ##Modify the record of linked
+ my $linkrecord=XMLgetauthorityhash($dbh,$linkid);
+ my $linktypecode=AUTHfind_authtypecode($dbh,$linkid);
+ my @linkfields=XML_readline_asarray($linkrecord,"linkid","authorities");
+ my $updated;
+ foreach my $linkfield (@linkfields){
+ if ($linkfield eq $authid){
+ XML_writeline_id($linkrecord,"linkid",$linkfield,"","authorities");
+ $updated=1;
+ }
+ }#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
+### they should have a system preference "dontmerge=1" otherwise by default biblios will be updated
+
+if (C4::Context->preference('dontmerge') ){
+# save the file in localfile/modified_authorities
+ my $cgidir = C4::Context->intranetdir ."/cgi-bin";
+ unless (opendir(DIR, "$cgidir")) {
+ $cgidir = C4::Context->intranetdir."/";
+ }
+
+ my $filename = $cgidir."/localfile/modified_authorities/$authid.authid";
+ open AUTH, "> $filename";
+ print AUTH $authid;
+ close AUTH;
+}else{
+ &merge($dbh,$authid,$record,$authid,$record);
+}
+return $authid;
+}
+
+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)=@_;
+ $dbh->do("delete from auth_header where authid=$authid") ;
+}
+
+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 FindDuplicateauth {
+### Should receive an xmlhash
+ my ($record,$authtypecode)=@_;
+ my $dbh = C4::Context->dbh;
+ 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;
+ # 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);
+ # there is at least 1 result => return the 1st one
+ if ($nbresult>0) {
+ return @$finalresult[0]->{authid},@$finalresult[0]->{summary};
+ }
+ # no result, returns nothing
+ return;
+}
+
+sub getsummary{
+## give this an XMLhash record to return summary
+my ($dbh,$record,$authid,$authtypecode)=@_;
+ my $authref = getauthtype($authtypecode);
+ my $summary = $authref->{summary};
+ # 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});
+ $summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
+ } 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;
+ } else {
+## $summary did not exist create a standard summary
+ 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);
+ }
+ }##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/>";
+ $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/>";
+ $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 />";
+ $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);
+ }
+ $seeheading.= " ".$seeheading."<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 />";
+ $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;
+ } 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;
+ } 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);
+ }
+ }##tag 2..
+ }
+ $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;
+}
+
+
+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
+
+ # 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;
+ # search all biblio tags using this authority.
+ $sth = $dbh->prepare("select distinct tagfield from biblios_subfield_structure where authtypecode=? ");
+ $sth->execute($authtypecodefrom);
+my @tags_using_authtype;
+ while (my ($tagfield) = $sth->fetchrow) {
+ push @tags_using_authtype,$tagfield ;
+ }
+## 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 $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();
+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;
+$z++;
+}
+$oResult->destroy();
+$oConnection[0]->destroy();
+ foreach my $xmlhash (@reccache){
+ my $update;
+ foreach my $tagfield (@tags_using_authtype){
+
+ ###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
+ 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]);
+ $update=1;
+ }#foreach $subfield
+ }#foreach tagfield
+ if ($update==1){
+ my $biblionumber=XML_readline_onerecord($xmlhash,"biblionumber","biblios");
+ my $frameworkcode=MARCfind_frameworkcode($dbh,$biblionumber);
+ NEWmodbiblio($dbh,$biblionumber,$xmlhash,$frameworkcode) ;
+ }
+
+ }#foreach $xmlhash
+}#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;
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+Paul POULAIN paul.poulain at free.fr
+
+=cut
+
+# $Id: AuthoritiesMarc.pm,v 1.1.2.1 2007/03/10 01:35:33 tgarip1957 Exp $
+
+# Revision 1.30 2006/09/06 16:21:03 tgarip1957
+# Clean up before final commits
+#
+# 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.
+#
+# Revision 1.9.2.5 2005/05/31 14:50:46 tipaul
+# fix for authority merging. There was a bug on official installs
+#
+# Revision 1.9.2.4 2005/05/30 11:24:15 tipaul
+# fixing a bug : when a field was repeated, the last field was also repeated. (Was due to the "empty" field in html between fields : to separate fields, in html, an empty field is automatically added. in AUTHhtml2marc, this empty field was not discarded correctly)
+#
+# Revision 1.9.2.3 2005/04/28 08:45:33 tipaul
+# porting FindDuplicate feature for authorities from HEAD to rel_2_2, works correctly now.
+#
+# Revision 1.9.2.2 2005/02/28 14:03:13 tipaul
+# * adding search on "main entry" (ie $a subfield) on a given authority (the "search everywhere" field is still here).
+# * adding a select box to requet "contain" or "begin with" search.
+# * fixing some bug in authority search (related to "main entry" search)
+#
+# Revision 1.9.2.1 2005/02/24 13:12:13 tipaul
+# saving authority modif in a text file. This will be used soon with another script (in crontab). The script in crontab will retrieve every authorityid in the directory localfile/authorities and modify every biblio using this authority. Those modifs may be long. So they can't be done through http, because we may encounter a webserver timeout, and kill the process before end of the job.
+# So, it will be done through a cron job.
+# (/me agree we need some doc for command line scripts)
+#
+# Revision 1.9 2004/12/23 09:48:11 tipaul
+# Minor changes in summary "exploding" (the 3 digits AFTER the subfield were not on the right place).
+#
+# Revision 1.8 2004/11/05 10:11:39 tipaul
+# export auth_count_usage (bugfix)
+#
+# Revision 1.7 2004/09/23 16:13:00 tipaul
+# Bugfix in modification
+#
+# Revision 1.6 2004/08/18 16:00:24 tipaul
+# fixes for authorities management
+#
+# Revision 1.5 2004/07/05 13:37:22 doxulting
+# First step for working authorities
+#
+# Revision 1.4 2004/06/22 11:35:37 tipaul
+# removing % at the beginning of a string to avoid loooonnnngggg searchs
+#
+# Revision 1.3 2004/06/17 08:02:13 tipaul
+# merging tag & subfield in auth_word for better perfs
+#
+# Revision 1.2 2004/06/10 08:29:01 tipaul
+# MARC authority management (continued)
+#
+# Revision 1.1 2004/06/07 07:35:01 tipaul
+# MARC authority management package
+#
+
Index: Biblio.pm
===================================================================
RCS file: Biblio.pm
diff -N Biblio.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Biblio.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,1553 @@
+package C4::Biblio;
+# New XML API added by tgarip at neu.edu.tr 25/08/06
+# 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
+use strict;
+require Exporter;
+use C4::Context;
+use XML::Simple;
+use Encode;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 2.01;
+
+ at ISA = qw(Exporter);
+
+# &itemcount removed, now resides in Search.pm
+#
+ at EXPORT = qw(
+
+&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_xml2hash_news
+&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
+
+);
+
+#################### 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;
+
+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'};
+
+ }
+ }
+ }
+ }##tag
+}## if tag is mapped
+return @value;
+}
+
+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
+
+($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
+
+}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{
+
+ foreach my $control (@$controlfields){
+ if ($control->{'tag'} eq $tag){
+ return $control->{'content'}if $control->{'content'};
+ }
+ }
+ }##tag
+}## Holding or not
+}## if tag is mapped
+return "";
+}
+
+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;
+}
+
+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;
+}
+
+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;
+}
+sub XML_xml2hash_news{
+##make a perl hash from xml file
+my ($xml)=@_;
+ my $hashed = XMLin( $xml ,KeyAttr =>['id','title','date','source','news']);
+#my $newhashed;
+#$newhashed->{'title'}=$hashed->{title}->[0];
+#$newhashed->{'date'}=$hashed->{date}->[0];
+#$newhashed->{'source'}=$hashed->{source}->[0];
+#$newhashed->{'news'}=$hashed->{news}->[0];
+return $hashed;
+}
+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);
+}
+
+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;
+}
+
+
+
+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;
+}
+
+
+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);
+
+ while(my ($marcxml)=$sth->fetchrow_array){
+$marcxml=Encode::decode('utf8',$marcxml);
+ push @results,$marcxml;
+}
+return @results;
+}
+
+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);
+
+## if @fields is given do not bother about the rest of fields just parse those
+
+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;
+
+ }
+ }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');
+ }
+ }
+
+## we only need the following for biblio data
+
+# 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};
+
+
+ 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;
+ }
+ }
+
+}
+
+ return ($result, at items);
+}
+sub XMLmarc2koha_onerecord {
+# warn "XMLmarc2koha_onerecord";
+##Returns a koha hash from MARCXML hash
+
+ my ($dbh,$xml,$related_record, at fields) = @_;
+ my ($result);
+
+## if @fields is given do not bother about the rest of fields just parse those
+
+ 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);
+ }
+ }
+ 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);
+ }
+
+}
+
+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;
+}
+
+#
+#
+# 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
+
+
+##Sub to match kohafield to Z3950 -attributes
+
+sub MARCfind_attr_from_kohafield {
+# warn "MARCfind_attr_from_kohafield";
+## returns attribute
+ my ( $kohafield ) = @_;
+ return 0, 0 unless $kohafield;
+
+ my $relations = C4::Context->attrfromkohafield;
+ return ($relations->{$kohafield});
+}
+
+
+sub MARCgettagslib {
+# warn "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 biblios_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 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;
+ }
+
+ $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"
+ );
+ $sth->execute($frameworkcode);
+
+ my $subfield;
+ my $authorised_value;
+ my $authtypecode;
+ my $value_builder;
+
+ my $seealso;
+ my $hidden;
+ my $isurl;
+ my $link;
+
+ 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;
+}
+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 );
+
+ 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,seealso,hidden,isurl,link from holdings_subfield_structure where frameworkcode=? order by tagfield,tagsubfield"
+ );
+ $sth->execute($frameworkcode);
+
+ my $subfield;
+ my $authorised_value;
+ my $authtypecode;
+ my $value_builder;
+
+ my $seealso;
+ my $hidden;
+ my $isurl;
+ my $link;
+
+ 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;
+}
+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]);
+}
+
+
+
+
+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;
+}
+
+
+
+sub MARChtml2xml {
+# warn "MARChtml2xml ";
+ my ($tags,$subfields,$values,$indicator,$ind_tag,$tagindex) = @_;
+ my $xml= "<record>";
+
+ 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 ((@$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;
+ }
+ }
+ }
+ } 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
+}
+
+
+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
+}
+
+
+
+
+
+
+
+
+##########################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 );
+}
+
+ return ( $biblionumber );
+}
+
+
+
+
+
+sub NEWmodbiblioframework {
+ my ($dbh,$biblionumber,$frameworkcode) =@_;
+ my $sth = $dbh->prepare("Update biblio SET frameworkcode=? WHERE biblionumber=$biblionumber");
+ $sth->execute($frameworkcode);
+ return 1;
+}
+
+
+sub NEWdelbiblio {
+ my ( $dbh, $biblionumber ) = @_;
+ZEBRAop($dbh,$biblionumber,"recordDelete","biblioserver");
+}
+
+
+sub NEWnewitem {
+ my ( $dbh, $xmlhash, $biblionumber ) = @_;
+ #my $itemtype= MARCfind_itemtype($dbh,$biblionumber);
+my $itemtype=XML_readline_onerecord($xmlhash,"ctype","holdings");
+## 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{
+
+##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);
+
+$xmlhash=XML_writeline($xmlhash,"dateaccessioned",$date,"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");
+}
+
+##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;
+
+##Add item to SQL
+my $itemnumber = &OLDnewitems( $dbh, $xmlhash );
+
+# add the item to zebra it will add the biblio as well!!!
+ ZEBRAop( $dbh, $biblionumber,"specialUpdate","biblioserver" );
+return $itemnumber;
+}## added new item
+
+}
+
+
+
+sub NEWmoditem{
+ my ( $dbh, $xmlhash, $biblionumber, $itemnumber ) = @_;
+
+##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");
+ my $ctype=XML_readline_onerecord($xmlhash,"ctype","holdings");
+ my $sth=$dbh->prepare("select notforloan from itemtypes where itemtype='$ctype'");
+$sth->execute();
+my $notforloan=$sth->fetchrow;
+##Change the notforloan field if $notforloan found
+ if ($notforloan >0){
+ $xmlhash=XML_writeline($xmlhash,"notforloan",$notforloan,"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");
+}
+
+##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,$ctype );
+ ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
+}
+
+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");
+
+}
+
+
+
+
+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);
+}
+
+sub NEWmodbiblio {
+ my ( $dbh, $biblionumber,$xmlhash,$frameworkcode ) = @_;
+##Add biblionumber incase lost on html
+
+$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);
+ OLDmodbiblio ($dbh,$xmlhash,$biblionumber,$frameworkcode);
+ my $ok=ZEBRAop($dbh,$biblionumber,"specialUpdate","biblioserver");
+ return ($biblionumber);
+}
+
+#
+#
+# OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD OLD
+#
+#
+
+sub OLDnewitems {
+
+ 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 $ctype=XML_readline_onerecord($xmlhash,"ctype","holdings");
+my $xml=XML_hash2xml($xmlhash);
+ $sth = $dbh->prepare( "Insert into items set itemnumber = ?, biblionumber = ?,barcode = ?,marcxml=?, ctype=?" );
+ $sth->execute($itemnumber,$biblionumber,$barcode,$xml,$ctype);
+ return $itemnumber;
+}
+
+sub OLDmoditem {
+ my ( $dbh, $xml,$biblionumber,$itemnumber,$barcode,$ctype ) = @_;
+ my $sth =$dbh->prepare("replace items set biblionumber=?,marcxml=?,barcode=? , itemnumber=?, ctype=?");
+ $sth->execute($biblionumber,$xml,$barcode,$itemnumber, $ctype);
+ $sth->finish;
+}
+
+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} );
+ }
+
+ #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;
+}
+
+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;
+}
+
+sub OLDdelbiblio {
+ my ( $dbh, $biblionumber ) = @_;
+ my $sth = $dbh->prepare("select * from biblio where biblionumber=?");
+ $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} );
+ }
+
+ #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;
+ }
+ $sth->finish;
+}
+
+
+#
+#
+#
+#ZEBRA ZEBRA ZEBRA
+#
+#
+
+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=?");
+
+$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);
+ }
+}
+
+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;
+
+}
+}
+
+sub ZEBRAopserver{
+
+###Accepts a $server variable thus we can use it to update biblios, authorities or other zebra dbs
+my ($record,$op,$server,$biblionumber)=@_;
+
+my @port;
+
+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;
+ }
+
+$Zpackage->destroy();
+$Zconnbiblio->destroy();
+return 1;
+}
+return 0;
+}
+
+
+sub ZEBRAopcommit {
+my $server=shift;
+return unless C4::Context->config($server."shadow");
+my $Zconnbiblio=C4::Context->Zconnauth($server);
+
+my $Zpackage = $Zconnbiblio->package();
+ $Zpackage->send('commit');
+
+ 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;
+ }
+$zebraxml.="</holdings>";
+$zebraxml.="</koharecord>";
+$zebraxml.="</kohacollection>";
+return $zebraxml;
+}
+
+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;
+ }
+$zebraxml.="</holdings>";
+$zebraxml.="</koharecord>";
+return $zebraxml;
+}
+
+#
+#
+# various utility subs and those not complying to new rules
+#
+#
+
+sub newbiblio {
+## Used in acqui management -- creates the biblio from koha hash
+ my ($biblio) = @_;
+ 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 $dbh = C4::Context->dbh;
+my $record=XMLkoha2marc($dbh,$biblio,"biblios");
+ my $biblionumber=NEWmodbiblio($dbh,$record,$biblio->{biblionumber});
+ return ($biblionumber);
+}
+
+sub newitems {
+## Used in acqui management -- creates the item from hash rather than marc-record
+ my ( $item, @barcodes ) = @_;
+ 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});
+
+ }
+ return $itemnumber ;
+}
+
+
+
+
+sub getitemtypes {
+ my $dbh = C4::Context->dbh;
+ my $query = "select * from itemtypes order by description";
+ my $sth = $dbh->prepare($query);
+
+ # || die "Cannot prepare $query" . $dbh->errstr;
+ my $count = 0;
+ my @results;
+ $sth->execute;
+ # || die "Cannot execute $query\n" . $sth->errstr;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $results[$count] = $data;
+ $count++;
+ } # while
+
+ $sth->finish;
+ return ( $count, @results );
+} # sub getitemtypes
+
+
+
+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);
+}
+
+
+
+
+
+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'){
+
+ $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);
+}
+
+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;
+
+}
+
+
+#### This function allows decoding of only title and author out of a MARC record
+ sub func_title_author {
+ my ($tagno,$tagdata) = @_;
+my ($titlef,$subf,$authf);
+ ($titlef,$subf)=&MARCfind_marc_from_kohafield("title","biblios");
+ ($authf,$subf)=&MARCfind_marc_from_kohafield("author","biblios");
+ return ($tagno == $titlef || $tagno == $authf);
+ }
+
+
+
+
+1;
+__END__
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+
+
Index: Biblioadd.pm
===================================================================
RCS file: Biblioadd.pm
diff -N Biblioadd.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Biblioadd.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,521 @@
+package C4::Biblioadd;
+# New PackageI added by tgarip at neu.edu.tr 25/02/07
+# 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
+use strict;
+require Exporter;
+use C4::Context;
+use XML::Simple;
+use Encode;
+use MARC::Record;
+use MARC::File::USMARC;
+use C4::Biblio;
+use Data::Dumper;
+use vars qw( $tagslib);
+use vars qw( $authorised_values_sth);
+
+my $format="USMARC";
+$format="UNIMARC" if (C4::Context->preference('marcflavour') eq 'UNIMARC');
+use MARC::File::XML(RecordFormat =>$format);
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 4.01;
+
+ at ISA = qw(Exporter);
+
+
+ at EXPORT = qw(
+&MARCfindbreeding
+&ImportDVD
+&build_authorized_values_list
+&create_input
+&build_tabs
+&build_hidden_data
+);
+
+=item MARCfindbreeding
+
+ $record = MARCfindbreeding($dbh, $breedingid,$frameworkcode);
+
+Look up the breeding farm with database handle $dbh, for the
+record with id $breedingid. If found, returns the decoded
+MARC::Record; otherwise, -1 is returned (FIXME).
+Returns as second parameter the character encoding.
+
+=cut
+
+sub MARCfindbreeding {
+ my ($dbh,$id,$oldbiblionumber) = @_;
+ my $sth = $dbh->prepare("select marc,encoding from marc_breeding where id=?");
+ $sth->execute($id);
+ my ($marc,$encoding) = $sth->fetchrow;
+ $sth->finish;
+ if ($marc) {
+ my $record = MARC::File::USMARC::decode($marc);
+ if (ref($record) eq undef) {
+ return -1;
+ }
+ if (C4::Context->preference("z3950NormalizeAuthor") and C4::Context->preference("z3950AuthorAuthFields")){
+ my ($tag,$subfield) = MARCfind_marc_from_kohafield("author","biblios");
+ my $auth_fields = C4::Context->preference("z3950AuthorAuthFields");
+ my @auth_fields= split /,/,$auth_fields;
+ my $field;
+ if ($record->field($tag)){
+ foreach my $tmpfield ($record->field($tag)->subfields){
+ my $subfieldcode=shift @$tmpfield;
+ my $subfieldvalue=shift @$tmpfield;
+ if ($field){
+ $field->add_subfields("$subfieldcode"=>$subfieldvalue) if ($subfieldcode ne $subfield);
+ } else {
+ $field=MARC::Field->new($tag,"","",$subfieldcode=>$subfieldvalue) if ($subfieldcode ne $subfield);
+ }
+ }
+ }
+ $record->delete_field($record->field($tag));
+ foreach my $fieldtag (@auth_fields){
+ next unless ($record->field($fieldtag));
+ my $lastname = $record->field($fieldtag)->subfield('a');
+ my $firstname= $record->field($fieldtag)->subfield('b');
+ my $title = $record->field($fieldtag)->subfield('c');
+ my $number= $record->field($fieldtag)->subfield('d');
+ if ($title){
+ $field->add_subfields("$subfield"=>ucfirst($title)." ".ucfirst($firstname)." ".$number);
+ }else{
+ $field->add_subfields("$subfield"=>ucfirst($firstname).", ".ucfirst($lastname));
+ }
+ }
+ $record->insert_fields_ordered($field);
+ }
+##Delete biblionumber tag in case a similar tag is used in imported MARC ##
+ my ( $tagfield, $tagsubfield ) =MARCfind_marc_from_kohafield("biblionumber","biblios");
+ my $old_field = $record->field($tagfield);
+ $record->delete_field($old_field);
+ ##add the old biblionumber if a modif but coming from breedingfarm
+ if ($oldbiblionumber){
+ my $newfield;
+ if ($tagfield<10){
+ $newfield = MARC::Field->new($tagfield, $oldbiblionumber);
+ }else{
+ $newfield = MARC::Field->new($tagfield, '', '', "$tagsubfield" => $oldbiblionumber);
+ }
+ $record->insert_fields_ordered($newfield);
+ }
+ my $xml=MARC::File::XML::record($record);
+
+ my $xmlhash=XML_xml2hash_onerecord($xml);
+ return $xmlhash,$encoding;
+
+ }
+ return -1;
+}
+
+=item ImportDVD
+
+=cut
+
+sub ImportDVD {
+my ($filename,$oldbiblionumber)=@_;
+
+## Fixme the path to be variable
+my $fullname=C4::Context->config('intranetdir')."/htdocs/uploaded-files/tmp-pdf/".$filename;
+
+my $xml;
+my $xmlhash;
+open(IN,"<" ,$fullname) or die $!;
+while (<IN>){
+$xml.=$_;
+}
+close(IN);
+$xml=Encode::encode('utf8',$xml);
+$xmlhash=XML_xml2hash_onerecord($xml);
+if ($oldbiblionumber){
+$xmlhash=XML_writeline($xmlhash,"biblionumber",$oldbiblionumber,"biblios");
+}
+return $xmlhash;
+}
+=item build_authorized_values_list
+
+=cut
+
+sub build_authorized_values_list {
+ my($tag, $subfield, $value, $dbh,$authorised_values_sth,$tagslib) = @_;
+
+ my @authorised_values;
+ my %authorised_lib;
+ my ($itemtype,$description);
+ # builds list, depending on authorised value...
+
+ #---- branch
+ if ($tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "branches" ) {
+ 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 ( ($itemtype,$description) = $sth->fetchrow_array) {
+ push @authorised_values, $itemtype;
+ $authorised_lib{$itemtype}=$description;
+ }
+ $value=$itemtype unless ($value);
+
+ #---- "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;
+ }
+ }
+ return CGI::scrolling_list( -name => 'field_value',
+ -values => \@authorised_values,
+ -default => $value,
+ -labels => \%authorised_lib,
+ -override => 1,
+ -size => 1,
+ -multiple => 0 );
+}
+
+=item create_input
+ builds the <input ...> entry for a subfield.
+=cut
+sub create_input {
+ my ($tag,$subfield,$value,$i,$tabloop,$rec,$authorised_values_sth,$id,$tagslib) = @_;
+ my $dbh=C4::Context->dbh;
+ $value =~ s/"/"/g;
+ my %subfield_data;
+ $subfield_data{id}=$id;
+ $subfield_data{tag}=$tag;
+ $subfield_data{subfield}=$subfield;
+ $subfield_data{marc_lib}="<span id=\"error$i\">".$tagslib->{$tag}->{$subfield}->{lib}."</span>";
+ $subfield_data{marc_lib_plain}=$tagslib->{$tag}->{$subfield}->{lib};
+ $subfield_data{tag_mandatory}=$tagslib->{$tag}->{mandatory};
+ $subfield_data{mandatory}=$tagslib->{$tag}->{$subfield}->{mandatory};
+ $subfield_data{repeatable}=$tagslib->{$tag}->{$subfield}->{repeatable};
+ $subfield_data{index} = $i;
+ $subfield_data{visibility} = "display:none" if (substr($tagslib->{$tag}->{$subfield}->{hidden},2,1) gt "0") ; #check parity
+ if ($tagslib->{$tag}->{$subfield}->{authorised_value}) {
+ $subfield_data{marc_value}= build_authorized_values_list($tag, $subfield, $value, $dbh,$authorised_values_sth,$tagslib);
+ # it's an authority field
+ } elsif ($tagslib->{$tag}->{$subfield}->{authtypecode}) {
+
+ $subfield_data{marc_value}="<input onblur=\"this.style.backgroundColor='#ffffff';\" onfocus=\"this.style.backgroundColor='#ffffff;'\"\" tabindex=\"1\" type=\"text\" name=\"field_value\" id=\"field_value$id\" value=\"$value\" size=\"40\" maxlength=\"255\" DISABLE READONLY> <a style=\"cursor: help;\" href=\"javascript:Dopop('../authorities/auth_finder.pl?authtypecode=".$tagslib->{$tag}->{$subfield}->{authtypecode}."&index=$id',$id);\">...</a>";
+ # it's a plugin field
+ } elsif ($tagslib->{$tag}->{$subfield}->{'value_builder'}) {
+ # opening plugin. Just check wether we are on a developper computer on a production one
+ # (the cgidir differs)
+ my $cgidir = C4::Context->intranetdir ."/cgi-bin/value_builder";
+ unless (opendir(DIR, "$cgidir")) {
+ $cgidir = C4::Context->intranetdir."/value_builder";
+ }
+ my $plugin=$cgidir."/".$tagslib->{$tag}->{$subfield}->{'value_builder'};
+ do $plugin;
+ my $extended_param = plugin_parameters($dbh,$rec,$tagslib,$i,$tabloop);
+ my ($function_name,$javascript) = plugin_javascript($dbh,$rec,$tagslib,$i,$tabloop);
+ $subfield_data{marc_value}="<input tabindex=\"1\" type=\"text\" name=\"field_value\" id=\"field_value$id\" value=\"$value\" size=\"40\" maxlength=\"255\" DISABLE READONLY OnFocus=\"javascript:Focus$function_name($i)\" OnBlur=\"javascript:Blur$function_name($i); \"> <a style=\"cursor: help;\" href=\"javascript:Clic$function_name($i)\">...</a> $javascript";
+ # it's an hidden field
+ } elsif ($tag eq '') {
+ $subfield_data{marc_value}="<input onblur=\"this.style.backgroundColor='#ffffff';\" onfocus=\"this.style.backgroundColor='#ffffff'; \" tabindex=\"1\" type=\"hidden\" name=\"field_value\" id=\"field_value$id\" value=\"$value\">";
+ } elsif (substr($tagslib->{$tag}->{$subfield}->{'hidden'},2,1) gt "1") {
+
+ $subfield_data{marc_value}="<input onblur=\"this.style.backgroundColor='#ffffff';\" onfocus=\"this.style.backgroundColor='#ffffff'; \" tabindex=\"1\" type=\"text\" name=\"field_value\" id=\"field_value$id\" value=\"$value\" size=\"40\" maxlength=\"255\" >";
+ # it's a standard field
+ } else {
+ if (length($value) >100) {
+ $subfield_data{marc_value}="<textarea tabindex=\"1\" name=\"field_value\" id=\"field_value$id\" cols=\"40\" rows=\"5\" >$value</textarea>";
+ } else {
+ $subfield_data{marc_value}="<input onblur=\"this.style.backgroundColor='#ffffff';\" onfocus=\"this.style.backgroundColor='#ffffff'; \" tabindex=\"1\" type=\"text\" name=\"field_value\" id=\"field_value$id\" value=\"$value\" size=\"50\">"; #"
+ }
+ }
+ return \%subfield_data;
+}
+
+sub build_tabs {
+ my($template, $xmlhash, $dbh,$addedfield,$tagslib,$authorised_values_sth) = @_;
+ # fill arrays
+ my @loop_data =();
+ my $tag;
+ my $i=0;
+my $id=100;
+
+my ($biblionumtagfield,$biblionumtagsubfield) = &MARCfind_marc_from_kohafield($dbh,"biblionumber","biblios");
+
+my $biblio;
+my $controlfields;
+my $leader;
+if ($xmlhash){
+ $biblio=$xmlhash->{'datafield'};
+ $controlfields=$xmlhash->{'controlfield'};
+ $leader=$xmlhash->{'leader'};
+}
+
+ my @BIG_LOOP;
+my %built;
+
+# loop through each tab 0 through 9
+for (my $tabloop = 0; $tabloop <= 9; $tabloop++) {
+
+ my @loop_data = ();
+ foreach my $tag (sort(keys (%{$tagslib}))) {
+ next if ($tag eq $biblionumtagfield);## Otherwise biblionumber will be duplicated on modifs if user has set visibility to true
+ my $indicator;
+ # if MARC::Record is not empty => use it as master loop, then add missing subfields that should be in the tab.
+ # if MARC::Record is empty => use tab as master loop.
+ my @subfields_data;
+
+ if ($xmlhash) {
+ ####
+ my %tagdefined;
+ my %definedsubfields;
+
+ my ($ind1,$ind2);
+
+ if ($tag>9){
+ foreach my $data (@$biblio){
+ my @subfields_data;
+ undef %definedsubfields;
+ if ($data->{'tag'} eq $tag){
+ $tagdefined{$tag}=1 ;
+ $ind1=" ";
+ $ind2=" ";
+ foreach my $subfieldcode ( $data->{'subfield'}){
+ foreach my $code ( @$subfieldcode){
+ next if ($tagslib->{$tag}->{$code->{'code'}}->{tab} ne $tabloop);
+ my $subfield=$code->{'code'} ;
+ my $value=$code->{'content'};
+ $definedsubfields{$tag.$subfield}=1 ;
+ $built{$tag}=1;
+ push(@subfields_data, &create_input($tag,$subfield,$value,$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib)) ;
+ $i++ ;
+ }
+ } ##each subfield
+ $ind1=$data->{'ind1'};
+ $ind2= $data->{'ind2'};
+
+
+ # now, loop again to add parameter subfield that are not in the MARC::Record
+
+ foreach my $subfield (sort( keys %{$tagslib->{$tag}})) {
+ next if (length $subfield !=1);
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ next if ((substr($tagslib->{$tag}->{$subfield}->{hidden},2,1) gt "1") ); #check for visibility flag
+ next if ($definedsubfields{$tag.$subfield} );
+ push(@subfields_data, &create_input($tag,$subfield,'',$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $definedsubfields{$tag.$subfield}=1;
+ $i++;
+ }
+ if ($#subfields_data >= 0) {
+ my %tag_data;
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{indicator} = $ind1.$ind2 if ($tag>=10);
+ $tag_data{subfield_loop} = \@subfields_data;
+ push (@loop_data, \%tag_data);
+
+ }
+ $id++;
+ }## if tag matches
+
+ }#eachdata
+ }else{ ## tag <10
+ if ($tag eq "000" || $tag eq "LDR"){
+ my $subfield="@";
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ my @subfields_data;
+ my $value=$leader->[0] if $leader->[0];
+ $tagdefined{$tag}=1 ;
+ push(@subfields_data, &create_input($tag,$subfield,$value,$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $i++;
+ if ($#subfields_data >= 0) {
+ my %tag_data;
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{subfield_loop} = \@subfields_data;
+ $tag_data{fixedfield} = 1;
+ push (@loop_data, \%tag_data);
+ }
+ }else{
+ foreach my $control (@$controlfields){
+ my $subfield="@";
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ my @subfields_data;
+ if ($control->{'tag'} eq $tag){
+ $tagdefined{$tag}=1 ;
+ my $value=$control->{'content'} ;
+ $definedsubfields{$tag.'@'}=1;
+ push(@subfields_data, &create_input($tag,$subfield,$value,$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $i++;
+
+ $built{$tag}=1;
+
+ if ($#subfields_data >= 0) {
+ my %tag_data;
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{subfield_loop} = \@subfields_data;
+ $tag_data{fixedfield} = 1;
+ push (@loop_data, \%tag_data);
+ }
+ $id++;
+ }## tag matches
+ }# each control
+ }
+ }##tag >9
+
+
+ ##### Any remaining tag
+ my @subfields_data;
+ # now, loop again to add parameter subfield that are not in the MARC::Record
+ foreach my $subfield (sort( keys %{$tagslib->{$tag}})) {
+ next if ($tagdefined{$tag} );
+ next if (length $subfield !=1);
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ next if ((substr($tagslib->{$tag}->{$subfield}->{hidden},2,1) gt "1") ); #check for visibility flag
+
+ push(@subfields_data, &create_input($tag,$subfield,'',$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $tagdefined{$tag.$subfield}=1;
+ $i++;
+ }
+ if ($#subfields_data >= 0) {
+ my %tag_data;
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{indicator} = $ind1.$ind2 if ($tag>=10);
+ $tag_data{subfield_loop} = \@subfields_data;
+ if ($tag<10) {
+ $tag_data{fixedfield} = 1;
+ }
+
+ push (@loop_data, \%tag_data);
+ }
+
+
+ if ($addedfield eq $tag) {
+ my %tag_data;
+ my @subfields_data;
+ $id++;
+ $tagdefined{$tag}=1 ;
+ foreach my $subfield (sort( keys %{$tagslib->{$tag}})) {
+ next if (length $subfield !=1);
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ next if ((substr($tagslib->{$tag}->{$subfield}->{hidden},2,1) gt "1") ); #check for visibility flag
+ $addedfield="";
+ push(@subfields_data, &create_input($tag,$subfield,'',$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $i++;
+ }
+ if ($#subfields_data >= 0) {
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{indicator} = ' ' if ($tag>=10);
+ $tag_data{subfield_loop} = \@subfields_data;
+ if ($tag<10) {
+ $tag_data{fixedfield} = 1;
+ }
+ push (@loop_data, \%tag_data);
+
+ }
+
+ }
+
+ # if breeding is empty
+ } else {
+ my @subfields_data;
+ foreach my $subfield (sort(keys %{$tagslib->{$tag}})) {
+ next if (length $subfield !=1);
+ next if ((substr($tagslib->{$tag}->{$subfield}->{hidden},2,1) gt "1") ); #check for visibility flag
+ next if ($tagslib->{$tag}->{$subfield}->{tab} ne $tabloop);
+ push(@subfields_data, &create_input($tag,$subfield,'',$i,$tabloop,$xmlhash,$authorised_values_sth,$id,$tagslib));
+ $i++;
+ }
+ if ($#subfields_data >= 0) {
+ my %tag_data;
+ $tag_data{tag} = $tag;
+ $tag_data{tag_lib} = $tagslib->{$tag}->{lib};
+ $tag_data{repeatable} = $tagslib->{$tag}->{repeatable};
+ $tag_data{indicator} = $indicator;
+ $tag_data{subfield_loop} = \@subfields_data;
+ $tag_data{tagfirstsubfield} = $tag_data{subfield_loop}[0];
+ if ($tag<10) {
+ $tag_data{fixedfield} = 1;
+ }
+ push (@loop_data, \%tag_data);
+
+ }
+ }
+ $id++;
+ }
+ if ($#loop_data >=0) {
+ my %big_loop_line;
+ $big_loop_line{number}=$tabloop;
+ $big_loop_line{innerloop}=\@loop_data;
+ push @BIG_LOOP,\%big_loop_line;
+ }
+
+ $template->param(BIG_LOOP => \@BIG_LOOP);
+#return \@BIG_LOOP;
+}## tab loop
+
+}
+
+
+sub build_hidden_data {
+ # build hidden data =>
+ # we store everything, even if we show only requested subfields.
+my $tagslib=shift;
+ my @loop_data =();
+ my $i=0;
+ foreach my $tag (keys %{$tagslib}) {
+ my $previous_tag = '';
+
+ # loop through each subfield
+ foreach my $subfield (keys %{$tagslib->{$tag}}) {
+ next if ($subfield eq 'lib');
+ next if ($subfield eq 'tab');
+ next if ($subfield eq 'mandatory');
+ next if ($subfield eq 'repeatable');
+ next if ($tagslib->{$tag}->{$subfield}->{'tab'} ne "-1");
+ my %subfield_data;
+ $subfield_data{marc_lib}=$tagslib->{$tag}->{$subfield}->{lib};
+ $subfield_data{marc_mandatory}=$tagslib->{$tag}->{$subfield}->{mandatory};
+ $subfield_data{marc_repeatable}=$tagslib->{$tag}->{$subfield}->{repeatable};
+ $subfield_data{marc_value}="<input type=\"hidden\" name=\"field_value[]\">";
+ push(@loop_data, \%subfield_data);
+ $i++
+ }
+return $tagslib;
+ }
+}
Index: BookShelves.pm
===================================================================
RCS file: BookShelves.pm
diff -N BookShelves.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ BookShelves.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,681 @@
+# -*- tab-width: 8 -*-
+# Please use 8-character tabs for this file (indents are every 4 characters)
+
+package C4::BookShelves;
+
+# $Id: BookShelves.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+# 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
+
+use strict;
+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;
+
+=head1 NAME
+
+C4::BookShelves - Functions for manipulating Koha virtual bookshelves
+
+=head1 SYNOPSIS
+
+ use C4::BookShelves;
+
+=head1 DESCRIPTION
+
+This module provides functions for manipulating virtual bookshelves,
+including creating and deleting bookshelves, and adding and removing
+items to and from bookshelves.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at 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
+
+=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.
+
+=back
+
+=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;
+}
+
+=item GetShelfList
+
+ $shelflist = &GetShelfList();
+ ($shelfnumber, $shelfhash) = each %{$shelflist};
+
+Looks up the virtual bookshelves, and returns a summary. C<$shelflist>
+is a reference-to-hash. The keys are the bookshelf numbers
+(C<$shelfnumber>, above), and the values (C<$shelfhash>, above) are
+themselves references-to-hash, with the following keys:
+
+=over 4
+
+=item C<$shelfhash-E<gt>{shelfname}>
+
+A string. The name of the shelf.
+
+=item C<$shelfhash-E<gt>{count}>
+
+The number of books on that bookshelf.
+
+=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,
+ 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);
+ 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;
+ $shelflist{$shelfnumber}->{'surname'} = $surname;
+ $shelflist{$shelfnumber}->{'firstname'} = $firstname;
+ $shelflist{$shelfnumber}->{'category'} = $category;
+
+
+ }
+
+ return(\%shelflist);
+}
+
+=item GetShelfContents
+
+ $itemlist = &GetShelfContents($env, $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.
+
+=cut
+#'
+sub GetShelfContents {
+ my ($env, $shelfnumber) = @_;
+ my @itemlist;
+ my $sth=$dbh->prepare("select itemnumber from shelfcontents where shelfnumber=? order by itemnumber");
+ $sth->execute($shelfnumber);
+ while (my ($itemnumber) = $sth->fetchrow) {
+ my ($item) = getiteminformation($env, $itemnumber, 0);
+ push (@itemlist, $item);
+ }
+ return (\@itemlist);
+}
+
+=item AddToShelf
+
+ &AddToShelf($env, $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) = @_;
+ return unless $itemnumber;
+ my $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) values (?, ?, 0)");
+ $sth->execute($shelfnumber, $itemnumber);
+ }
+}
+sub AddToShelfFromBiblio {
+ my ($env, $biblionumber, $shelfnumber) = @_;
+ return unless $biblionumber;
+ my $sth = $dbh->prepare("select itemnumber from items where biblionumber=?");
+ $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);
+ }
+}
+
+=item RemoveFromShelf
+
+ &RemoveFromShelf($env, $itemnumber, $shelfnumber);
+
+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.
+
+=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");
+ }
+}
+
+=item RemoveShelf
+
+ ($status, $msg) = &RemoveShelf($env, $shelfnumber);
+
+Deletes virtual bookshelf number C<$shelfnumber>. The bookshelf must
+be empty.
+
+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
+#'
+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'});
+ }
+
+ $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;
+ }
+
+ return($total_shelves, \@results);
+}
+
+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'};
+
+ foreach my $row (@{$careers}) {
+ $sth = $dbh->prepare("INSERT INTO bookshelves_careers VALUES (?,?)");
+ $sth->execute($shelfnumber, $row);
+ }
+ return $shelfnumber;
+ }
+}
+
+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);
+
+ $sth = $dbh->prepare("DELETE FROM bookshelves_careers WHERE shelfnumber = ?");
+ $sth->execute($shelfnumber);
+
+ foreach my $row (@{$careers}) {
+ $sth = $dbh->prepare("INSERT INTO bookshelves_careers VALUES (?,?)");
+ $sth->execute($shelfnumber, $row);
+ }
+ return $shelfnumber;
+ }
+}
+
+
+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;
+}
+
+sub GetShelfInfo {
+ my ($shelfnumber, $owner) = @_;
+ my $sth = $dbh->prepare("SELECT * FROM bookshelf WHERE shelfnumber = ?");
+ $sth->execute($shelfnumber);
+ my $result = $sth->fetchrow_hashref;
+
+ if ($result->{'owner'} == $owner) {
+ $result->{'canmanage'} = 1;
+ }
+
+ 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 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);
+
+ return (\@results);
+}
+
+sub RemoveFromShelfExt {
+ my ($biblionumber, $shelfnumber) = @_;
+ my $sth = $dbh->prepare("DELETE FROM shelfcontents WHERE shelfnumber = ? AND biblionumber = ?");
+ $sth->execute($shelfnumber,$biblionumber);
+}
+
+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);
+ }
+}
+
+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 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;
+}
+
+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;
+
+ 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);
+}
+
+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;
+}
+
+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);
+}
+
+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;
+}
+
+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;
+}
+
+END { } # module clean-up code here (global destructor)
+
+1;
+
+#
+# $Log: BookShelves.pm,v $
+# Revision 1.1.2.1 2007/03/10 01:35:34 tgarip1957
+# fresh files for rel_TG
+#
+# 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.13 2004/03/11 16:06:20 tipaul
+# *** empty log message ***
+#
+# Revision 1.11.2.2 2004/02/19 10:15:41 tipaul
+# new feature : adding book to bookshelf from biblio detail screen.
+#
+# Revision 1.11.2.1 2004/02/06 14:16:55 tipaul
+# fixing bugs in bookshelves management.
+#
+# Revision 1.11 2003/12/15 10:57:08 slef
+# DBI call fix for bug 662
+#
+# 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.9 2002/10/13 08:29:18 arensb
+# Deleted unused variables.
+# Removed trailing whitespace.
+#
+# Revision 1.8 2002/10/10 04:32:44 arensb
+# Simplified references.
+#
+# 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.6.2.1 2002/10/04 02:24:43 arensb
+# Use C4::Connect instead of C4::Database, C4::Connect->dbh instead
+# C4Connect.
+#
+# Revision 1.6 2002/09/23 13:50:30 arensb
+# Fixed missing bit in POD.
+#
+# Revision 1.5 2002/09/22 17:29:17 arensb
+# Added POD.
+# Added some FIXME comments.
+# Removed useless trailing whitespace.
+#
+# 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.
+#
+#
+1;
+__END__
+
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=head1 SEE ALSO
+
+C4::Circulation::Circ2(3)
+
+=cut
Index: Bookfund.pm
===================================================================
RCS file: Bookfund.pm
diff -N Bookfund.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Bookfund.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,571 @@
+package C4::Bookfund;
+
+# 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: Bookfund.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Bookfund - Koha functions for dealing with bookfund, currency & money.
+
+=head1 SYNOPSIS
+
+use C4::Bookfund;
+
+=head1 DESCRIPTION
+
+the functions in this modules deal with bookfund, currency and money.
+They allow to get and/or set some informations for a specific budget or currency.
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &GetBookFund &GetBookFunds &GetBookFundsId &GetBookFundBreakdown &GetCurrencies
+ &NewBookFund
+ &ModBookFund &ModCurrencies
+ &SearchBookFund
+ &Countbookfund
+ &ConvertCurrency
+ &DelBookFund
+);
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+#-------------------------------------------------------------#
+
+=head3 GetBookFund
+
+=over 4
+
+$dataaqbookfund = &GetBookFund($bookfundid);
+
+this function get the bookfundid, bookfundname, the bookfundgroup, the branchcode
+from aqbookfund table for bookfundid given on input arg.
+return:
+C<$dataaqbookfund> is a hashref full of bookfundid, bookfundname, bookfundgroup,
+and branchcode.
+
+=back
+
+=cut
+
+sub GetBookFund {
+ my $bookfundid = shift;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT
+ bookfundid,
+ bookfundname,
+ bookfundgroup,
+ branchcode
+ FROM aqbookfund
+ WHERE bookfundid = ?
+ ";
+ my $sth=$dbh->prepare($query);
+$sth->execute($bookfundid);
+ return $sth->fetchrow_hashref;
+}
+
+
+=head3 GetBookFundsId
+
+=over 4
+
+$sth = &GetBookFundsId
+Read on aqbookfund table and execute a simple SQL query.
+
+return:
+$sth->execute. Don't forget to fetch row from the database after using
+this function by using, for example, $sth->fetchrow_hashref;
+
+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
+ FROM aqbookfund
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ return $sth;
+}
+
+#-------------------------------------------------------------#
+
+=head3 GetBookFunds
+
+=over 4
+
+ at results = &GetBookFunds;
+
+Returns a list of all book funds.
+
+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 ) {
+ $strsth = "
+ SELECT *
+ FROM aqbookfund,aqbudget
+ WHERE aqbookfund.bookfundid=aqbudget.bookfundid
+ AND startdate<=now()
+ AND enddate>now()
+ AND (aqbookfund.branchcode IS NULL OR aqbookfund.branchcode='' OR aqbookfund.branchcode= ? )
+ GROUP BY aqbookfund.bookfundid ORDER BY bookfundname";
+ }
+ else {
+ $strsth = "
+ SELECT *
+ FROM aqbookfund,
+ aqbudget
+ WHERE aqbookfund.bookfundid=aqbudget.bookfundid
+ AND startdate<now()
+ AND enddate>now()
+ GROUP BY aqbookfund.bookfundid ORDER BY bookfundname
+ ";
+ }
+ my $sth = $dbh->prepare($strsth);
+ if ( $branch ) {
+ $sth->execute($branch);
+ }
+ else {
+ $sth->execute;
+ }
+ my @results = ();
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
+ }
+ $sth->finish;
+ return @results;
+}
+
+#-------------------------------------------------------------#
+
+=head3 GetCurrencies
+
+=over 4
+
+ at currencies = &GetCurrencies;
+
+Returns the list of all known currencies.
+
+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 {
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT *
+ FROM currency
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my @results = ();
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
+ }
+ $sth->finish;
+ return @results;
+}
+
+#-------------------------------------------------------------#
+
+=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 {
+ my ( $id, $year, $start, $end ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # if no start/end dates given defaut to everything
+ if ( !$start ) {
+ $start = '0000-00-00';
+ $end = 'now()';
+ }
+
+ # do a query for spent totals.
+ my $query = "
+ SELECT quantity,datereceived,freight,unitprice,listprice,ecost,
+ quantityreceived,subscription
+ FROM aqorders
+ LEFT JOIN aqorderbreakdown ON aqorders.ordernumber=aqorderbreakdown.ordernumber
+ WHERE bookfundid=?
+ AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')
+ AND ((datereceived >= ? and datereceived < ?) OR (budgetdate >= ? and budgetdate < ?))
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $id, $start, $end, $start, $end );
+
+ my $spent = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ if ( $data->{'subscription'} == 1 ) {
+ $spent += $data->{'quantity'} * $data->{'unitprice'};
+ }
+ else {
+
+ my $leftover = $data->{'quantity'} - $data->{'quantityreceived'};
+ $spent += ( $data->{'unitprice'} ) * $data->{'quantityreceived'};
+
+ }
+ }
+
+ # then do a seperate query for commited totals, (pervious single query was
+ # returning incorrect comitted results.
+
+ my $query = "
+ SELECT quantity,datereceived,freight,unitprice,
+ listprice,ecost,quantityreceived AS qrev,
+ subscription,biblio.title,itemtype,aqorders.biblionumber,
+ aqorders.booksellerinvoicenumber,
+ quantity-quantityreceived AS tleft,
+ aqorders.ordernumber AS ordnum,entrydate,budgetdate,
+ booksellerid,aqbasket.basketno
+ FROM aqorderbreakdown,
+ aqbasket,
+ aqorders
+ LEFT JOIN biblio ON biblio.biblionumber=aqorders.biblionumber
+ WHERE bookfundid=?
+ AND aqorders.ordernumber=aqorderbreakdown.ordernumber
+ AND aqorders.basketno=aqbasket.basketno
+ AND (budgetdate >= ? AND budgetdate < ?)
+ AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')
+ ";
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $id, $start, $end );
+
+ my $comtd;
+
+ my $total = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ my $left = $data->{'tleft'};
+ if ( !$left || $left eq '' ) {
+ $left = $data->{'quantity'};
+ }
+ if ( $left && $left > 0 ) {
+ my $subtotal = $left * $data->{'ecost'};
+ $data->{subtotal} = $subtotal;
+ $data->{'left'} = $left;
+ $comtd += $subtotal;
+ }
+ }
+
+ $sth->finish;
+ return ( $spent, $comtd );
+}
+
+=head3 NewBookFund
+
+=over 4
+
+&NewBookFund(bookfundid, bookfundname, branchcode);
+
+this function create a new bookfund into the database.
+
+=back
+
+=cut
+
+sub NewBookFund{
+ my ($bookfundid, $bookfundname, $branchcode) = @_;
+ $branchcode = undef unless $branchcode;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ INSERT
+ INTO aqbookfund
+ (bookfundid, bookfundname, branchcode)
+ VALUES
+ (?, ?, ?)
+ ";
+ my $sth=$dbh->prepare($query);
+ $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 $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqbookfund
+ SET bookfundname = ?,
+ branchcode = ?
+ WHERE bookfundid = ?
+ ";
+ my $sth=$dbh->prepare($query);
+ $sth->execute($bookfundname,$branchcode,$bookfundid);
+# budgets depending on a bookfund must have the same branchcode
+# if the bookfund branchcode is set
+ if (defined $branchcode) {
+ $query = "
+ UPDATE aqbudget
+ SET branchcode = ?
+ ";
+ $sth=$dbh->prepare($query);
+ $sth->execute($branchcode);
+ }
+}
+
+#-------------------------------------------------------------#
+
+=head3 SearchBookFund
+
+=over 4
+ at 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 {
+ my $dbh = C4::Context->dbh;
+ my ($filter,
+ $filter_bookfundid,
+ $filter_bookfundname,
+ $filter_branchcode
+ ) = @_;
+
+ my @bindings;
+
+ my $query = "
+ SELECT bookfundid,
+ bookfundname,
+ bookfundgroup,
+ branchcode
+ FROM aqbookfund
+ WHERE 1 = 1 ";
+
+ if ($filter) {
+ if ($filter_bookfundid) {
+ $query.= "AND bookfundid = ?";
+ push @bindings, $filter_bookfundid;
+ }
+ if ($filter_bookfundname) {
+ $query.= "AND bookfundname like ?";
+ push @bindings, '%'.$filter_bookfundname.'%';
+ }
+ if ($filter_branchcode) {
+ $query.= "AND branchcode = ?";
+ push @bindings, $filter_branchcode;
+ }
+ }
+ $query.= "ORDER BY bookfundid";
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bindings);
+ my @results;
+ while (my $row = $sth->fetchrow_hashref) {
+ push @results, $row;
+ }
+ return @results;
+}
+
+#-------------------------------------------------------------#
+
+=head3 ModCurrencies
+
+=over 4
+
+&ModCurrencies($currency, $newrate);
+
+Sets the exchange rate for C<$currency> to be C<$newrate>.
+
+=back
+
+=cut
+
+sub ModCurrencies {
+ my ( $currency, $rate ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE currency
+ SET rate=?
+ WHERE currency=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $rate, $currency );
+}
+
+#-------------------------------------------------------------#
+
+=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 $dbh = C4::Context->dbh;
+ my $query ="
+ SELECT COUNT(*)
+ FROM aqbookfund
+ WHERE bookfundid = ?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($bookfundid);
+ return $sth->fetchrow;
+}
+
+
+#-------------------------------------------------------------#
+
+=head3 ConvertCurrency
+
+=over 4
+
+$foreignprice = &ConvertCurrency($currency, $localprice);
+
+Converts the price C<$localprice> to foreign currency C<$currency> by
+dividing by the exchange rate, and returns the result.
+
+If no exchange rate is found, C<&ConvertCurrency> assumes the rate is one
+to one.
+
+=back
+
+=cut
+
+sub ConvertCurrency {
+ my ( $currency, $price ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT rate
+ FROM currency
+ WHERE currency=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($currency);
+ my $cur = ( $sth->fetchrow_array() )[0];
+ if ( $cur == 0 ) {
+ $cur = 1;
+ }
+ return ( $price / $cur );
+}
+
+#-------------------------------------------------------------#
+
+=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 $dbh = C4::Context->dbh;
+ my $query = "
+ DELETE FROM aqbookfund
+ WHERE bookfundid=?
+ ";
+ my $sth=$dbh->prepare($query);
+ $sth->execute($bookfundid);
+ $sth->finish;
+ $query = "
+ DELETE FROM aqbudget where bookfundid=?
+ ";
+ $sth=$dbh->prepare($query);
+ $sth->execute($bookfundid);
+ $sth->finish;
+}
+
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Bookseller.pm
===================================================================
RCS file: Bookseller.pm
diff -N Bookseller.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Bookseller.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,275 @@
+package C4::Bookseller;
+
+# 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: Bookseller.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+require Exporter;
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &GetBookSeller &GetBooksellersWithLateOrders
+ &ModBookseller
+ &AddBookseller
+);
+
+
+=head1 NAME
+
+C4::Bookseller - Koha functions for dealing with booksellers.
+
+=head1 SYNOPSIS
+
+use C4::Bookseller;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with booksellers. They allow to
+add a new bookseller, to modify it or to get some informations around
+a bookseller.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+#-------------------------------------------------------------------#
+
+=head3 GetBookSeller
+
+=over 4
+
+ at results = &GetBookSeller($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<@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 {
+ my ($searchstring) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT *
+ FROM aqbooksellers
+ WHERE name LIKE ? OR id = ?
+ ";
+ my $sth =$dbh->prepare($query);
+ $sth->execute("$searchstring%", $searchstring );
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
+ }
+ $sth->finish;
+ return @results ;
+}
+
+
+#-----------------------------------------------------------------#
+
+=head3 GetBooksellersWithLateOrders
+
+=over 4
+
+%results = &GetBooksellersWithLateOrders;
+
+Searches for suppliers with late orders.
+
+=back
+
+=cut
+
+sub GetBooksellersWithLateOrders {
+ my $delay = shift;
+ my $dbh = C4::Context->dbh;
+
+# FIXME NOT quite sure that this operation is valid for DBMs different from Mysql, HOPING so
+# should be tested with other DBMs
+
+ my $strsth;
+ my $dbdriver = C4::Context->config("db_scheme") || "mysql";
+ if ( $dbdriver eq "mysql" ) {
+ $strsth = "
+ SELECT DISTINCT aqbasket.booksellerid, aqbooksellers.name
+ FROM aqorders, aqbasket
+ LEFT JOIN aqbooksellers ON aqbasket.booksellerid = aqbooksellers.id
+ WHERE aqorders.basketno = aqbasket.basketno
+ AND (closedate < DATE_SUB(CURDATE( ),INTERVAL $delay DAY)
+ AND (datereceived = '' OR datereceived IS NULL))
+ ";
+ }
+ else {
+ $strsth = "
+ SELECT DISTINCT aqbasket.booksellerid, aqbooksellers.name
+ FROM aqorders, aqbasket
+ LEFT JOIN aqbooksellers ON aqbasket.aqbooksellerid = aqbooksellers.id
+ WHERE aqorders.basketno = aqbasket.basketno
+ AND (closedate < (CURDATE( )-(INTERVAL $delay DAY)))
+ AND (datereceived = '' OR datereceived IS NULL))
+ ";
+ }
+
+ my $sth = $dbh->prepare($strsth);
+ $sth->execute;
+ my %supplierlist;
+ while ( my ( $id, $name ) = $sth->fetchrow ) {
+ $supplierlist{$id} = $name;
+ }
+
+ return %supplierlist;
+}
+
+#--------------------------------------------------------------------#
+
+=head3 AddBookseller
+
+=over 4
+
+$id = &AddBookseller($bookseller);
+
+Creates a new bookseller. C<$bookseller> is a reference-to-hash whose
+keys are the fields of the aqbooksellers table in the Koha database.
+All fields must be present.
+
+Returns the ID of the newly-created bookseller.
+
+=back
+
+=cut
+
+sub AddBookseller {
+ my ($data) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ INSERT INTO aqbooksellers
+ (
+ name, address1, address2, address3, address4,
+ postal, phone, fax, url, contact,
+ contpos, contphone, contfax, contaltphone, contemail,
+ contnotes, active, listprice, invoiceprice, gstreg,
+ listincgst,invoiceincgst, specialty, discount, invoicedisc,
+ nocalc, notes
+ )
+ VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data->{'name'}, $data->{'address1'},
+ $data->{'address2'}, $data->{'address3'},
+ $data->{'address4'}, $data->{'postal'},
+ $data->{'phone'}, $data->{'fax'},
+ $data->{'url'}, $data->{'contact'},
+ $data->{'contpos'}, $data->{'contphone'},
+ $data->{'contfax'}, $data->{'contaltphone'},
+ $data->{'contemail'}, $data->{'contnotes'},
+ $data->{'active'}, $data->{'listprice'},
+ $data->{'invoiceprice'}, $data->{'gstreg'},
+ $data->{'listincgst'}, $data->{'invoiceincgst'},
+ $data->{'specialty'}, $data->{'discount'},
+ $data->{'invoicedisc'}, $data->{'nocalc'},
+ $data->{'notes'}
+ );
+
+ # return the id of this new supplier
+ my $query = "
+ SELECT max(id)
+ FROM aqbooksellers
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ return scalar($sth->fetchrow);
+}
+
+#-----------------------------------------------------------------#
+
+=head3 ModSupplier
+
+=over 4
+
+&ModSupplier($bookseller);
+
+Updates the information for a given bookseller. C<$bookseller> is a
+reference-to-hash whose keys are the fields of the aqbooksellers table
+in the Koha database. It must contain entries for all of the fields.
+The entry to modify is determined by C<$bookseller-E<gt>{id}>.
+
+The easiest way to get all of the necessary fields is to look up a
+book seller with C<&booksellers>, modify what's necessary, then call
+C<&ModSupplier> with the result.
+
+=back
+
+=cut
+
+sub ModBookseller {
+ my ($data) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE aqbooksellers
+ SET name=?,address1=?,address2=?,address3=?,address4=?,
+ postal=?,phone=?,fax=?,url=?,contact=?,contpos=?,
+ contphone=?,contfax=?,contaltphone=?,contemail=?,
+ contnotes=?,active=?,listprice=?, invoiceprice=?,
+ gstreg=?, listincgst=?,invoiceincgst=?,
+ specialty=?,discount=?,invoicedisc=?,nocalc=?, notes=?
+ WHERE id=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data->{'name'}, $data->{'address1'},
+ $data->{'address2'}, $data->{'address3'},
+ $data->{'address4'}, $data->{'postal'},
+ $data->{'phone'}, $data->{'fax'},
+ $data->{'url'}, $data->{'contact'},
+ $data->{'contpos'}, $data->{'contphone'},
+ $data->{'contfax'}, $data->{'contaltphone'},
+ $data->{'contemail'}, $data->{'contnotes'},
+ $data->{'active'}, $data->{'listprice'},
+ $data->{'invoiceprice'}, $data->{'gstreg'},
+ $data->{'listincgst'}, $data->{'invoiceincgst'},
+ $data->{'specialty'}, $data->{'discount'},
+ $data->{'invoicedisc'}, $data->{'nocalc'},
+ $data->{'notes'}, $data->{'id'}
+ );
+ $sth->finish;
+}
+
+
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Boolean.pm
===================================================================
RCS file: Boolean.pm
diff -N Boolean.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Boolean.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,122 @@
+package C4::Boolean;
+
+# $Id: Boolean.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+#package to handle Boolean values in the parameters table
+# Note: This is just a utility module; it should not be instantiated.
+
+
+# Copyright 2003 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
+
+use strict;
+use POSIX;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Boolean - Convenience functions to handle boolean values
+in the parameter table
+
+=head1 SYNOPSIS
+
+ use C4::Boolean;
+
+=head1 DESCRIPTION
+
+In the parameter table, there are various Boolean values that
+variously require a 0/1, no/yes, false/true, or off/on values.
+This module aims to provide scripts a means to interpret these
+Boolean values in a consistent way which makes common sense.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = (
+ &INVALID_BOOLEAN_STRING_EXCEPTION
+ );
+
+ at EXPORT_OK = qw(
+ true_p
+ );
+
+sub INVALID_BOOLEAN_STRING_EXCEPTION ()
+ { 'The given value does not seem to be interpretable as a Boolean value' }
+
+use vars qw( %strings );
+
+%strings = (
+ '0' => 0, '1' => 1, # C
+ '-1' => 1, # BASIC
+ 'nil' => 0, 't' => 1, # LISP
+ 'false' => 0, 'true' => 1, # Pascal
+ 'off' => 0, 'on' => 1,
+ 'no' => 0, 'yes' => 1,
+ 'n' => 0, 'y' => 1,
+);
+
+=item true_p
+
+ if ( C4::Boolean::true_p(C4::Context->preference("insecure")) ) {
+ ...
+ }
+
+Tries to interpret the passed string as a Boolean value. Returns
+the value if the string can be interpreted as such; otherwise an
+exception is thrown.
+
+=cut
+
+sub true_p ($) {
+ my($x) = @_;
+ my $it;
+ if (!defined $x || ref($x) ne '') {
+ die INVALID_BOOLEAN_STRING_EXCEPTION;
+ }
+ $x = lc($x);
+ $x =~ s/\s//g;
+ if (defined $strings{$x}) {
+ $it = $strings{$x};
+ } else {
+ die INVALID_BOOLEAN_STRING_EXCEPTION;
+ }
+ return $it;
+}
+
+
+#---------------------------------
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Breeding.pm
===================================================================
RCS file: Breeding.pm
diff -N Breeding.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Breeding.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,200 @@
+package C4::Breeding;
+
+# 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
+
+use strict;
+use C4::Biblio;
+use C4::Search;
+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
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Breeding : script to add a biblio in marc_breeding table.
+
+=head1 SYNOPSIS
+ &ImportBreeding($marcrecords,$overwrite_biblio,$filename,$z3950random);
+
+ C<$marcrecord> => the MARC::Record
+ C<$overwrite_biblio> => if set to 1 a biblio with the same ISBN will be overwritted.
+ if set to 0 a biblio with the same isbn will be ignored (the previous will be kept)
+ if set to -1 the biblio will be added anyway (more than 1 biblio with the same ISBN possible in the breeding
+ C<$encoding> => USMARC
+ or UNIMARC. used for char_decoding.
+ If not present, the parameter marcflavour is used instead
+ C<$z3950random> => the random value created during a z3950 search result.
+
+=head1 DESCRIPTION
+
+This is for depository of records coming from z3950 or directly imported.
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&ImportBreeding &BreedingSearch);
+
+sub ImportBreeding {
+ my ($marcrecords,$overwrite_biblio,$filename,$encoding,$z3950random) = @_;
+## use marc:batch send them in one by one
+# 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=?");
+ $encoding = C4::Context->preference("marcflavour") unless $encoding;
+ # fields used for import results
+ my $imported=0;
+ my $alreadyindb = 0;
+ 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);
+ my @warnings = $marcrecord->warnings();
+ if (scalar($marcrecord->fields()) == 0) {
+ $notmarcrecord++;
+ } else {
+ my $xmlhash=XML_xml2hash_onerecord($marcxml);
+ my $oldbiblio = XMLmarc2koha_onerecord($dbh,$xmlhash,'biblios');
+ # 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->{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);
+ }
+ }
+ if ($count>0 && !$z3950random) {
+ $alreadyindb++;
+ } else {
+ # search in breeding farm
+
+ if ($oldbiblio->{isbn}) {
+ $searchbreeding->execute($oldbiblio->{isbn},$oldbiblio->{title});
+ ($breedingid) = $searchbreeding->fetchrow;
+ } elsif ($oldbiblio->{issn}){
+ $searchbreeding->execute($oldbiblio->{issn},$oldbiblio->{title});
+ ($breedingid) = $searchbreeding->fetchrow;
+ }
+ if ($breedingid && $overwrite_biblio eq 0) {
+ $alreadyinfarm++;
+ } else {
+ my $recoded=MARC::Record->new_from_xml($marcxml,"UTF-8");
+ $recoded->encoding('UTF-8');
+
+ 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);
+ } else {
+ $insertsql ->execute($filename,substr($oldbiblio->{isbn}.$oldbiblio->{issn},0,10),$oldbiblio->{title},$oldbiblio->{author},$recoded->as_usmarc,$encoding,$z3950random,$oldbiblio->{classification},$oldbiblio->{subclass});
+
+ $breedingid=$dbh->{'mysql_insertid'};
+ }
+ $imported++;
+ }
+ }
+ }
+ #}
+ return ($notmarcrecord,$alreadyindb,$alreadyinfarm,$imported,$breedingid);
+}
+
+
+=item BreedingSearch
+
+ ($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.
+
+C<$count> is the number of items in C<@results>. C<@results> is an
+array of references-to-hash; the keys are the items from the C<marc_breeding> table of the Koha database.
+
+=cut
+
+sub BreedingSearch {
+ my ($title,$isbn,$z3950random) = @_;
+ my $dbh = C4::Context->dbh;
+ my $count = 0;
+ my ($query, at bind);
+ my $sth;
+ my @results;
+
+ $query = "Select id,file,isbn,title,author,classification,subclass from marc_breeding where ";
+ if ($z3950random) {
+ $query .= "z3950random = ?";
+ @bind=($z3950random);
+ } else {
+ @bind=();
+ if ($title) {
+ $query .= "title like ?";
+ push(@bind,"$title%");
+ }
+ if ($title && $isbn) {
+ $query .= " and ";
+ }
+ if ($isbn) {
+ $query .= "isbn like ?";
+ push(@bind,"$isbn%");
+ }
+ }
+ $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ while (my $data = $sth->fetchrow_hashref) {
+ $results[$count] = $data;
+ $count++;
+ } # while
+
+ $sth->finish;
+ return($count, @results);
+} # sub breedingsearch
+
+
+1;
+__END__
\ No newline at end of file
Index: Context.pm
===================================================================
RCS file: Context.pm
diff -N Context.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Context.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,952 @@
+# Copyright 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: Context.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+package C4::Context;
+use strict;
+use DBI;
+use CGI;
+use C4::Boolean;
+use XML::Simple;
+require Exporter;
+use vars qw($VERSION $AUTOLOAD),
+ qw($context),
+ qw(@context_stack);
+
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+=head1 NAME
+
+C4::Context - Maintain and manipulate the context of a Koha script
+
+=head1 SYNOPSIS
+
+ use C4::Context;
+
+ use C4::Context("/path/to/koha.xml");
+
+ $config_value = C4::Context->config("config_variable");
+ $db_handle = C4::Context->dbh;
+ $stopwordhash = C4::Context->stopwords;
+
+=head1 DESCRIPTION
+
+When a Koha script runs, it makes use of a certain number of things:
+configuration settings in F</etc/koha.xml>, a connection to the Koha
+databases, and so forth. These things make up the I<context> in which
+the script runs.
+
+This module takes care of setting up the context for a script:
+figuring out which configuration file to load, and loading it, opening
+a connection to the right database, and so forth.
+
+Most scripts will only use one context. They can simply have
+
+ use C4::Context;
+
+at the top.
+
+Other scripts may need to use several contexts. For instance, if a
+library has two databases, one for a certain collection, and the other
+for everything else, it might be necessary for a script to use two
+different contexts to search both databases. Such scripts should use
+the C<&set_context> and C<&restore_context> functions, below.
+
+By default, C4::Context reads the configuration from
+F</etc/koha.xml>. This may be overridden by setting the C<$KOHA_CONF>
+environment variable to the pathname of a configuration file to use.
+
+=head1 METHODS
+
+=over 2
+
+=cut
+
+#'
+# In addition to what is said in the POD above, a Context object is a
+# reference-to-hash with the following fields:
+#
+# config
+# A reference-to-hash whose keys and values are the
+# configuration variables and values specified in the config
+# file (/etc/koha.xml).
+# dbh
+# A handle to the appropriate database for this context.
+# dbh_stack
+# Used by &set_dbh and &restore_dbh to hold other database
+# handles for this context.
+# Zconn
+# A connection object for the Zebra server
+
+use constant CONFIG_FNAME => "/etc/koha.xml";
+ # Default config file, if none is specified
+
+#$context = undef; # Initially, no context is set
+ at 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
+
+ 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
+{
+ my $name = shift;
+
+ for ($name) {
+# FIXME - Should have other databases.
+ if (/mysql/i) { return("mysql"); }
+ if (/Postgres|Pg|PostgresSQL/) { return("Pg"); }
+ if (/oracle/i) { return("Oracle"); }
+ }
+ return undef; # Just in case
+}
+
+sub import
+{
+ my $package = shift;
+ my $conf_fname = shift; # Config file name
+ my $context;
+
+ # Create a new context from the given config file name, if
+ # any, then set it as the current context.
+ $context = new C4::Context($conf_fname);
+ return undef if !defined($context);
+ $context->set_context;
+}
+
+=item new
+
+ $context = new C4::Context;
+ $context = new C4::Context("/path/to/koha.xml");
+
+Allocates a new context. Initializes the context from the specified
+file, which defaults to either the file given by the C<$KOHA_CONF>
+environment variable, or F</etc/koha.xml>.
+
+C<&new> does not set this context as the new default context; for
+that, use C<&set_context>.
+
+=cut
+
+#'
+# Revision History:
+# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
+sub new
+{
+ my $class = shift;
+ my $conf_fname = shift; # Config file to load
+ my $self = {};
+
+ # check that the specified config file exists and is not empty
+ undef $conf_fname unless
+ (defined $conf_fname && -e $conf_fname && -s $conf_fname);
+ # Figure out a good config file to load if none was specified.
+ if (!defined($conf_fname))
+ {
+ # If the $KOHA_CONF environment variable is set, use
+ # that. Otherwise, use the built-in default.
+ $conf_fname = $ENV{"KOHA_CONF"} || CONFIG_FNAME;
+ }
+ # Load the desired config file.
+ $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->{"mcgi"} = undef; # CGI handle
+ $self->{"Zconn"} = undef; # Zebra Connection
+ $self->{"Zconnauth"} = undef; # Zebra Connection for updating
+ $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
+
+ bless $self, $class;
+ return $self;
+}
+
+=item set_context
+
+ $context = new C4::Context;
+ $context->set_context();
+or
+ set_context C4::Context $context;
+
+ ...
+ restore_context C4::Context;
+
+In some cases, it might be necessary for a script to use multiple
+contexts. C<&set_context> saves the current context on a stack, then
+sets the context to C<$context>, which will be used in future
+operations. To restore the previous context, use C<&restore_context>.
+
+=cut
+
+#'
+sub set_context
+{
+ my $self = shift;
+ my $new_context; # The context to set
+
+ # Figure out whether this is a class or instance method call.
+ #
+ # We're going to make the assumption that control got here
+ # through valid means, i.e., that the caller used an instance
+ # or class method call, and that control got here through the
+ # usual inheritance mechanisms. The caller can, of course,
+ # break this assumption by playing silly buggers, but that's
+ # harder to do than doing it properly, and harder to check
+ # for.
+ if (ref($self) eq "")
+ {
+ # Class method. The new context is the next argument.
+ $new_context = shift;
+ } else {
+ # Instance method. The new context is $self.
+ $new_context = $self;
+ }
+
+ # Save the old context, if any, on the stack
+ push @context_stack, $context if defined($context);
+
+ # Set the new context
+ $context = $new_context;
+}
+
+=item restore_context
+
+ &restore_context;
+
+Restores the context set by C<&set_context>.
+
+=cut
+
+#'
+sub restore_context
+{
+ my $self = shift;
+
+ if ($#context_stack < 0)
+ {
+ # Stack underflow.
+ die "Context stack underflow";
+ }
+
+ # Pop the old context and set it.
+ $context = pop @context_stack;
+
+ # FIXME - Should this return something, like maybe the context
+ # that was current when this was called?
+}
+
+=item config
+
+ $value = C4::Context->config("config_variable");
+
+ $value = C4::Context->config_variable;
+
+Returns the value of a variable specified in the configuration file
+from which the current context was created.
+
+The second form is more compact, but of course may conflict with
+method names. If there is a configuration variable called "new", then
+C<C4::Config-E<gt>new> will not return it.
+
+=cut
+
+#'
+sub config
+{
+ my $self = shift;
+ my $var = shift; # The config variable to return
+
+ return undef if !defined($context->{"config"});
+ # 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->{"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
+{
+ my $self = shift;
+ my $var = shift; # The config variable to return
+
+ return undef if !defined($context->{"server"});
+ # Return the value of the requested config variable
+ return $context->{"server"}->{$var};
+}
+=item preference
+
+ $sys_preference = C4::Context->preference("some_variable");
+
+Looks up the value of the given system preference in the
+systempreferences table of the Koha database, and returns it. If the
+variable is not set, or in case of error, returns the undefined value.
+
+=cut
+
+#'
+# FIXME - The preferences aren't likely to change over the lifetime of
+# the script (and things might break if they did change), so perhaps
+# this function should cache the results it finds.
+sub preference
+{
+ my $self = shift;
+ my $var = shift; # The system preference to return
+ my $retval; # Return value
+ my $dbh = C4::Context->dbh; # Database handle
+ my $sth; # Database query handle
+
+ # Look up systempreferences.variable==$var
+ $retval = $dbh->selectrow_array(<<EOT);
+ SELECT value
+ FROM systempreferences
+ WHERE variable='$var'
+ LIMIT 1
+EOT
+ return $retval;
+}
+
+sub boolean_preference ($) {
+ my $self = shift;
+ my $var = shift; # The system preference to return
+ my $it = preference($self, $var);
+ return defined($it)? C4::Boolean::true_p($it): undef;
+}
+
+# AUTOLOAD
+# This implements C4::Config->foo, and simply returns
+# C4::Context->config("foo"), as described in the documentation for
+# &config, above.
+
+# FIXME - Perhaps this should be extended to check &config first, and
+# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
+# code, so it'd probably be best to delete it altogether so as not to
+# encourage people to use it.
+sub AUTOLOAD
+{
+ my $self = shift;
+
+ $AUTOLOAD =~ s/.*:://; # Chop off the package name,
+ # leaving only the function name.
+ return $self->config($AUTOLOAD);
+}
+
+=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.
+
+=cut
+
+sub Zconn {
+ my $self = shift;
+my $server=shift;
+my $syntax=shift;
+# if ( defined($context->{"Zconn"}->{$server}) ) {
+# return $context->{"Zconn"}->{$server};
+
+ # No connection object or it died. Create one.
+# } else {
+ $context->{"Zconn"} = &new_Zconn($server,$syntax);
+ return $context->{"Zconn"};
+# }
+}
+
+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
+
+Internal helper function. creates a new database connection from
+the data given in the current context and returns it.
+
+=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();
+
+ $Zconn=create ZOOM::Connection($o);
+ $Zconn->connect($host,$port);
+
+ 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($host,$port);
+return $Zconnauth;
+}
+
+## cgi handler
+sub mcgi {
+ my $self = shift;
+ if (defined($context->{"mcgi"})) {
+ return $context->{"mcgi"};
+ # No connection object or it died. Create one.
+ } else {
+
+ $context->{"mcgi"} = &_new_cgi();
+ return $context->{"mcgi"};
+ }
+}
+## _new_cgi creates a CGI handle
+
+sub _new_cgi{
+my $cgi=CGI->new();
+return $cgi;
+}
+
+# _new_dbh
+# Internal helper function (not a method!). This creates a new
+# database connection from the data given in the current context, and
+# returns it.
+sub _new_dbh
+{
+ ##correct name for db_schme
+ my $db_driver;
+ if ($context->config("db_scheme")){
+ $db_driver=db_scheme2dbi($context->config("db_scheme"));
+ }else{
+ $db_driver="mysql";
+ }
+
+ my $db_name = $context->config("database");
+ my $db_host = $context->config("hostname");
+ my $db_user = $context->config("user");
+ my $db_passwd = $context->config("pass");
+ 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.
+ $dbh->do("set NAMES 'utf8'");
+
+
+ return $dbh;
+}
+
+=item dbh
+
+ $dbh = C4::Context->dbh;
+
+Returns a database handle connected to the Koha database for the
+current context. If no connection has yet been made, this method
+creates one, and connects to the database.
+
+This database handle is cached for future use: if you call
+C<C4::Context-E<gt>dbh> twice, you will get the same handle both
+times. If you need a second database handle, use C<&new_dbh> and
+possibly C<&set_dbh>.
+
+=cut
+
+#'
+sub dbh
+{
+ my $self = shift;
+ if (defined($context->{"dbh"}) && !$ENV{MOD_PERL}) {
+ my $sth=$context->{"dbh"}->prepare("select 1");
+ return $context->{"dbh"} if (defined($sth->execute));
+ }
+ $context->{"dbh"} = &_new_dbh();
+ return $context->{"dbh"};
+}
+
+=item new_dbh
+
+ $dbh = C4::Context->new_dbh;
+
+Creates a new connection to the Koha database for the current context,
+and returns the database handle (a C<DBI::db> object).
+
+The handle is not saved anywhere: this method is strictly a
+convenience function; the point is that it knows which database to
+connect to so that the caller doesn't have to know.
+
+=cut
+
+#'
+sub new_dbh
+{
+ my $self = shift;
+
+ return &_new_dbh();
+}
+
+=item set_dbh
+
+ $my_dbh = C4::Connect->new_dbh;
+ C4::Connect->set_dbh($my_dbh);
+ ...
+ C4::Connect->restore_dbh;
+
+C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
+C<&set_context> and C<&restore_context>.
+
+C<&set_dbh> saves the current database handle on a stack, then sets
+the current database handle to C<$my_dbh>.
+
+C<$my_dbh> is assumed to be a good database handle.
+
+=cut
+
+#'
+sub set_dbh
+{
+ my $self = shift;
+ my $new_dbh = shift;
+
+ # Save the current database handle on the handle stack.
+ # We assume that $new_dbh is all good: if the caller wants to
+ # screw himself by passing an invalid handle, that's fine by
+ # us.
+ push @{$context->{"dbh_stack"}}, $context->{"dbh"};
+ $context->{"dbh"} = $new_dbh;
+}
+
+=item restore_dbh
+
+ C4::Context->restore_dbh;
+
+Restores the database handle saved by an earlier call to
+C<C4::Context-E<gt>set_dbh>.
+
+=cut
+
+#'
+sub restore_dbh
+{
+ my $self = shift;
+
+ if ($#{$context->{"dbh_stack"}} < 0)
+ {
+ # Stack underflow
+ die "DBH stack underflow";
+ }
+
+ # Pop the old database handle and set it.
+ $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
+
+ # FIXME - If it is determined that restore_context should
+ # return something, then this function should, too.
+}
+
+=item marcfromkohafield
+
+ $dbh = C4::Context->marcfromkohafield;
+
+Returns a hash with marcfromkohafield.
+
+This hash is cached for future use: if you call
+C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
+
+=cut
+
+#'
+sub marcfromkohafield
+{
+ my $retval = {};
+
+ # If the hash already exists, return it.
+ return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
+
+ # No hash. Create one.
+ $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
+
+ return $context->{"marcfromkohafield"};
+}
+
+
+# _new_marcfromkohafield
+# Internal helper function (not a method!).
+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 ");
+ $sth->execute;
+ while (my ($kohafield,$tagfield,$tagsubfield,$recordtype) = $sth->fetchrow) {
+ my $retval = {};
+ $marcfromkohafield->{$recordtype}->{$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;
+
+Returns a hash with stopwords.
+
+This hash is cached for future use: if you call
+C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
+
+=cut
+
+#'
+sub stopwords
+{
+ my $retval = {};
+
+ # If the hash already exists, return it.
+ return $context->{"stopwords"} if defined($context->{"stopwords"});
+
+ # No hash. Create one.
+ $context->{"stopwords"} = &_new_stopwords();
+
+ return $context->{"stopwords"};
+}
+
+# _new_stopwords
+# Internal helper function (not a method!). This creates a new
+# hash with stopwords
+sub _new_stopwords
+{
+ my $dbh = C4::Context->dbh;
+ my $stopwordlist;
+ my $sth = $dbh->prepare("select word from stopwords");
+ $sth->execute;
+ while (my $stopword = $sth->fetchrow_array) {
+ my $retval = {};
+ $stopwordlist->{$stopword} = uc($stopword);
+ }
+ $stopwordlist->{A} = "A" unless $stopwordlist;
+ return $stopwordlist;
+}
+
+=item userenv
+
+ C4::Context->userenv;
+
+Builds a hash for user environment variables.
+
+This hash shall be cached for future use: if you call
+C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
+
+set_userenv is called in Auth.pm
+
+=cut
+
+#'
+sub userenv
+{
+ my $var = $context->{"activeuser"};
+ return $context->{"userenv"}->{$var} if (defined $context->{"userenv"}->{$var});
+ return 0;
+ warn "NO CONTEXT for $var";
+}
+
+=item set_userenv
+
+ C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $userflags, $emailaddress);
+
+Informs a hash for user environment variables.
+
+This hash shall be cached for future use: if you call
+C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
+
+set_userenv is called in Auth.pm
+
+=cut
+#'
+sub set_userenv{
+ my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress,$branchprinter)= @_;
+ my $var=$context->{"activeuser"};
+ my $cell = {
+ "number" => $usernum,
+ "id" => $userid,
+ "cardnumber" => $usercnum,
+# "firstname" => $userfirstname,
+# "surname" => $usersurname,
+#possibly a law problem
+ "branch" => $userbranch,
+ "branchname" => $branchname,
+ "flags" => $userflags,
+ "emailaddress" => $emailaddress,
+ "branchprinter" => $branchprinter,
+ };
+ $context->{userenv}->{$var} = $cell;
+ return $cell;
+}
+
+=item _new_userenv
+
+ C4::Context->_new_userenv($session);
+
+Builds a hash for user environment variables.
+
+This hash shall be cached for future use: if you call
+C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
+
+_new_userenv is called in Auth.pm
+
+=cut
+
+#'
+sub _new_userenv
+{
+ shift;
+ my ($sessionID)= @_;
+ $context->{"activeuser"}=$sessionID;
+}
+
+=item _unset_userenv
+
+ C4::Context->_unset_userenv;
+
+Destroys the hash for activeuser user environment variables.
+
+=cut
+#'
+
+sub _unset_userenv
+{
+ my ($sessionID)= @_;
+ undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
+}
+
+
+
+1;
+__END__
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item C<KOHA_CONF>
+
+Specifies the configuration file to read.
+
+=back
+
+=head1 SEE ALSO
+
+DBI(3)
+
+=head1 AUTHOR
+
+Andrew Arensburger <arensb at ooblick dot com>
+
+=cut
+# $Log: Context.pm,v $
+# Revision 1.1.2.1 2007/03/10 01:35:34 tgarip1957
+# fresh files for rel_TG
+#
+# Revision 1.50 2006/11/06 21:01:43 tgarip1957
+# Bug fixing and complete removal of Date::Manip
+#
+# 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
+#
+# Revision 1.48 2006/10/01 21:48:54 tgarip1957
+# Field weighting applied to ranked searches. A new facets table in mysql db
+#
+# Revision 1.47 2006/09/27 19:53:52 tgarip1957
+# Finalizing main components. All koha modules are now working with the new XML API
+#
+# Revision 1.46 2006/09/06 16:21:03 tgarip1957
+# Clean up before final commits
+#
+# Revision 1.43 2006/08/10 12:49:37 toins
+# sync with dev_week.
+#
+# Revision 1.42 2006/07/04 14:36:51 toins
+# Head & rel_2_2 merged
+#
+# Revision 1.41 2006/05/20 14:36:09 tgarip1957
+# Typo error. Missing '>'
+#
+# Revision 1.40 2006/05/20 14:28:02 tgarip1957
+# Adding support to read zebra database name from config files
+#
+# 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)
+#
+# 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 .
+#
+# branchprinter : the library can select a default printer for a branch
+#
+# Revision 1.38 2006/05/14 00:22:31 tgarip1957
+# Adding support for getting details of different zebra servers
+#
+# 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.36 2006/05/09 13:28:08 tipaul
+# adding the branchname and the librarian name in every page :
+# - modified userenv to add branchname
+# - modifier menus.inc to have the librarian name & userenv displayed on every page. they are in a librarian_information div.
+#
+# Revision 1.35 2006/04/13 08:40:11 plg
+# bug fixed: typo on Zconnauth name
+#
+# Revision 1.34 2006/04/10 21:40:23 tgarip1957
+# A new handler defined for zebra Zconnauth with read/write permission. Zconnauth should only be called in biblio.pm where write operations are. Use of this handler will break things unless koha.conf contains new variables:
+# zebradb=localhost
+# zebraport=<your port>
+# zebrauser=<username>
+# zebrapass=<password>
+#
+# The zebra.cfg file should read:
+# perm.anonymous:r
+# perm.username:rw
+# passw.c:<yourpasswordfile>
+#
+# Password file should be prepared with Apaches htpasswd utility in encrypted mode and should exist in a folder zebra.cfg can read
+#
+# Revision 1.33 2006/03/15 11:21:56 plg
+# bug fixed: utf-8 data where not displayed correctly in screens. Supposing
+# your data are truely utf-8 encoded in your database, they should be
+# correctly displayed. "set names 'UTF8'" on mysql connection (C4/Context.pm)
+# is mandatory and "binmode" to utf8 (C4/Interface/CGI/Output.pm) seemed to
+# converted data twice, so it was removed.
+#
+# Revision 1.32 2006/03/03 17:25:01 hdl
+# Bug fixing : a line missed a comment sign.
+#
+# Revision 1.31 2006/03/03 16:45:36 kados
+# Remove the search that tests the Zconn -- warning, still no fault
+# tollerance
+#
+# Revision 1.30 2006/02/22 00:56:59 kados
+# First go at a connection object for Zebra. You can now get a
+# connection object by doing:
+#
+# my $Zconn = C4::Context->Zconn;
+#
+# My initial tests indicate that as soon as your funcion ends
+# (ie, when you're done doing something) the connection will be
+# closed automatically. There may be some other way to make the
+# connection more stateful, I'm not sure...
+#
+# Local Variables:
+# tab-width: 4
+# End:
Index: Date-new.pm
===================================================================
RCS file: Date-new.pm
diff -N Date-new.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Date-new.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,232 @@
+#!/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-new.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+package C4::Date;
+
+use strict;
+use C4::Context;
+use Date::Calc qw(:all);
+
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(
+ &display_date_format
+ &format_date
+ &format_date_in_iso
+ &get_date_format_string_for_DHTMLcalendar
+ &DATE_diff &DATE_Add
+&get_today
+&DATE_subtract
+);
+
+sub get_date_format {
+
+ #Get the database handle
+ my $dbh = C4::Context->dbh;
+ return C4::Context->preference('dateformat');
+}
+
+sub display_date_format {
+ my $dateformat = get_date_format();
+
+ if ( $dateformat eq "us" ) {
+ return "mm/dd/yyyy";
+ }
+ elsif ( $dateformat eq "metric" ) {
+ return "dd/mm/yyyy";
+ }
+ elsif ( $dateformat eq "iso" ) {
+ return "yyyy-mm-dd";
+ }
+ 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
+{
+ my $olddate = shift;
+ my $newdate;
+
+ if ( ! $olddate )
+ {
+ return "";
+ }
+
+# 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" )
+ {
+ $newdate = sprintf("%02d/%02d/%04d",$day,$month,$year);
+ }
+ 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";
+ }
+# warn "newdate :$newdate";
+ }
+ return $newdate;
+}
+
+
+sub format_date_in_iso
+{
+ my $olddate = shift;
+ my $newdate;
+
+ if ( ! $olddate )
+ {
+ return "";
+ }
+ 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;
+ }
+}
+
+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;
+}
+
+sub get_today{
+my ($year,$month,$day)=Today();
+return sprintf("%04d-%02d-%02d",$year,$month,$day);
+}
+
+###Utility functions for serials management
+sub DATE_diff {
+## returns 1 if date1>date2 0 if date1==date2 -1 if date1<date2
+my ($date1,$date2)=@_;
+my ($year1,$month1,$day1)=Parse_Date($date1);
+my ($year2,$month2,$day2)=Parse_Date($date2);
+return Delta_Days($year1,$month1,$day1, $year2,$month2,$day2)
+}
+
+sub DATE_Add {
+## $amount in days
+my ($date,$amount)=@_;
+my ($year,$month,$day)=Parse_Date($date);
+($year,$month,$day) = Add_Delta_Days($year,$month,$day, $amount);
+return sprintf("%04d-%02d-%02d",$year,$month,$day);
+}
+
+
+
+
+
+
+
+
+sub DATE_subtract{
+my ($date1,$date2)=@_;
+my ($year1,$month1,$day1)=Parse_Date($date1);
+my ($year2,$month2,$day2)=Parse_Date($date2);
+my $lower = Date_to_Days($year1,$month1,$day1);
+ my $upper = Date_to_Days($year2,$month2,$day2);
+
+return ($lower-$upper);
+}
+1;
+__END__
Index: Date.pm
===================================================================
RCS file: Date.pm
diff -N Date.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Date.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,218 @@
+#!/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.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+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);
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(
+ &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 {
+
+ #Get the database handle
+ my $dbh = C4::Context->dbh;
+ return C4::Context->preference('dateformat');
+}
+
+sub display_date_format {
+ my $dateformat = get_date_format();
+
+ if ( $dateformat eq "us" ) {
+ return "mm/dd/yyyy";
+ }
+ elsif ( $dateformat eq "metric" ) {
+ return "dd/mm/yyyy";
+ }
+ elsif ( $dateformat eq "iso" ) {
+ return "yyyy-mm-dd";
+ }
+ 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 {
+ my $olddate = shift;
+ my $newdate;
+ if ( !$olddate || $olddate eq "0000-00-00" ) {
+ return "";
+ }
+ $olddate=~s/-//g;
+ $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('/');
+
+ }
+ elsif ( $dateformat eq "metric" ) {
+ return $newdate->dmy('/');
+ }
+ elsif ( $dateformat eq "iso" ) {
+ return $newdate->ymd;
+ }
+ else {
+ return
+"Invalid date format: $dateformat. Please change in system preferences";
+ }
+
+}
+
+sub format_date_in_iso {
+ my $olddate = shift;
+ my $newdate;
+ my $parser;
+ if ( !$olddate || $olddate eq "0000-00-00" ) {
+ 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->now;
+$dt->add(hours=>2);
+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";
+}
+
+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);
+}
+1;
+__END__
Index: Format.pm
===================================================================
RCS file: Format.pm
diff -N Format.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Format.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,232 @@
+package C4::Format;
+
+# $Id: Format.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+# 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
+
+use strict;
+require Exporter;
+
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Format - Functions for pretty-printing strings and numbers
+
+=head1 SYNOPSIS
+
+ use C4::Format;
+
+=head1 DESCRIPTION
+
+These functions return pretty-printed versions of strings and numbers.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&fmtstr &fmtdec);
+
+=item fmtstr
+
+ $str = &fmtstr($env, $string, $format);
+
+Returns C<$string>, padded with space to a given length.
+
+C<$format> is either C<Ln> or C<Rn>, where I<n> is a positive integer.
+C<$str> will be either left-padded or right-padded, respectively.
+
+C<&fmtstr> is almost equivalent to
+
+ sprintf("%-n.ns", $string);
+
+or
+
+ sprintf("%n.ns", $string);
+
+The only difference is that if I<n> is less than the length of
+C<$string>, then C<&fmtstr> will return the last I<n> characters of
+C<$string>, whereas C<sprintf> will return the first I<n> characters.
+
+C<$env> is ignored.
+
+=cut
+#'
+sub fmtstr {
+ # format (space pad) a string
+ # $fmt is Ln.. or Rn.. where n is the length
+ my ($env,$strg,$fmt)=@_;
+ my $align = substr($fmt,0,1);
+ my $lenst = substr($fmt,1,length($fmt)-1);
+ if ($align eq"R" ) {
+ $strg = substr((" "x$lenst).$strg,0-$lenst,$lenst);
+ } elsif ($align eq "C" ) {
+ $strg =
+ substr((" "x(($lenst/2)-(length($strg)/2))).$strg.(" "x$lenst),0,$lenst);
+ } else {
+ $strg = substr($strg.(" "x$lenst),0,$lenst);
+ }
+ return ($strg);
+}
+
+=item fmtdec
+
+ $str = &fmtdec($env, $number, $format)
+
+Returns a pretty-printed version of C<$number>.
+
+C<$format> specifies how to print the number. It is of the form
+
+ [$][,]n[m]
+
+where I<n> and I<m> are digits, specifying the number of digits to use
+before and after the decimal, respectively. Thus,
+
+ &fmtdec(undef, 123.456, "42")
+
+will return
+
+ " 123.45"
+
+If I<n> is smaller than the size of the integer part, only the last
+I<n> digits will be returned. If I<m> is greater than the number of
+digits after the decimal in C<$number>, the result will be
+right-padded with zeros.
+
+If C<$format> has a leading dollar sign, the number is assumed to be a
+monetary amount. C<$str> will have a dollar sign prepended to the
+value.
+
+If C<$format> has a comma after the optional dollar sign, the integer
+part will be split into three-digit groups separated by commas.
+
+C<$env> is effectively ignored.
+
+=cut
+#'
+# FIXME - This is all terribly provincial, not at all
+# internationalized. I'm pretty sure there's already something out
+# there that'll figure out the current locale, look up the local
+# currency symbol (and whether it goes on the left or right), figure
+# out how numbers are grouped (commas, periods, or what? And how many
+# digits per group?), and will print the whole thing prettily.
+# But I can't find it just now. Maybe POSIX::setlocale() or
+# perllocale(1) might help.
+# FIXME - Bug:
+# fmtdec(undef, 12345.6, ',82') prints " 345.60"
+# fmtdec(undef, 12345.6, '$,82') prints ".60"
+sub fmtdec {
+ # format a decimal
+ # $fmt is [$][,]n[m]
+ my ($env,$numb,$fmt)=@_;
+
+ # FIXME - Use $fmt =~ /^(\$)?(,)?(\d)(\d)?$/ instead of this mess of
+ # substr()s.
+
+ # See if there's a leading dollar sign.
+ my $curr = substr($fmt,0,1);
+ if ($curr eq "\$") {
+ $fmt = substr($fmt,1,length($fmt)-1);
+ };
+ # See if there's a leading comma
+ my $comma = substr($fmt,0,1);
+ if ($comma eq ",") {
+ $fmt = substr($fmt,1,length($fmt)-1);
+ };
+ # See whether one number was given, or two.
+ my $right;
+ my $left = substr($fmt,0,1);
+ if (length($fmt) == 1) {
+ $right = 0;
+ } else {
+ $right = substr($fmt,1,1);
+ }
+ # See if $numb is a floating-point number.
+ my $fnumb = "";
+ my $tempint = "";
+ my $tempdec = "";
+ # FIXME - Use
+ # $numb =~ /(\d+)\.(\d+)/;
+ # $tempint = $1 + 0;
+ # $tempdec = $2;
+ if (index($numb,".") == 0 ){
+ $tempint = 0;
+ $tempdec = substr($numb,1,length($numb)-1);
+ } else {
+ if (index($numb,".") > 0) {
+ my $decpl = index($numb,".");
+ $tempint = substr($numb,0,$decpl);
+ $tempdec = substr($numb,$decpl+1,length($numb)-1-$decpl);
+ } else {
+ $tempint = $numb;
+ $tempdec = 0;
+ }
+ # If a comma was specified, then comma-separate the integer part
+ # FIXME - From the Perl Cookbook (ISBN 1-56592-243-3), sec. 2.1.7:
+ # sub commify {
+ # my $test = reverse $_[0];
+ # $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
+ # return scalar reverse $text;
+ # }
+ if ($comma eq ",") {
+ while (length($tempdec) > 3) {
+ $fnumb = ",".substr($tempint,-3,3).$fnumb;
+ substr($tempint,-3,3) = "";
+ }
+ $fnumb = substr($tempint,-3,3).$fnumb;
+ } else {
+ $fnumb = $tempint;
+ }
+ }
+ # If a dollar sign was specified, prepend a dollar sign and
+ # right-justify the number
+ if ($curr eq "\$") {
+ $fnumb = fmtstr($env,$curr.$fnumb,"R".$left+1);
+ } else {
+ if ($left==0) {
+ $fnumb = "";
+ } else {
+ $fnumb = fmtstr($env,$fnumb,"R".$left);
+ }
+ }
+ # Right-pad the decimal part to the given number of digits.
+ if ($right > 0) {
+ $tempdec .= "0"x$right;
+ $tempdec = substr($tempdec,0,$right);
+ $fnumb .= ".".$tempdec;
+ }
+ return $fnumb; # FIXME - Shouldn't return a list.
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Input.pm
===================================================================
RCS file: Input.pm
diff -N Input.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Input.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,220 @@
+package C4::Input; #assumes C4/Input
+
+
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Input - Miscellaneous sanity checks
+
+=head1 SYNOPSIS
+
+ use C4::Input;
+
+=head1 DESCRIPTION
+
+This module provides functions to see whether a given library card
+number or ISBN is valid.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &checkdigit &checkvalidisbn
+ &buildCGIsort
+);
+
+# FIXME - This is never used.
+#sub checkflds {
+# my ($env,$reqflds,$data) = @_;
+# my $numrflds = @$reqflds;
+# my @probarr;
+# my $i = 0;
+# while ($i < $numrflds) {
+# if ($data->{@$reqflds[$i]} eq "") {
+# push(@probarr, @$reqflds[$i]);
+# }
+# $i++
+# }
+# return (\@probarr);
+#}
+
+=item checkdigit
+
+ $valid = &checkdigit($env, $cardnumber $nounique);
+
+Takes a card number, computes its check digit, and compares it to the
+checkdigit at the end of C<$cardnumber>. Returns a true value iff
+C<$cardnumber> has a valid check digit.
+
+C<$env> is ignored.
+
+=cut
+#'
+sub checkdigit {
+
+ my ($env,$infl, $nounique) = @_;
+ $infl = uc $infl;
+
+
+ #Check to make sure the cardnumber is unique
+
+ #FIXME: We should make the error for a nonunique cardnumber
+ #different from the one where the checkdigit on the number is
+ #not correct
+
+ unless ( $nounique )
+ {
+ my $dbh=C4::Context->dbh;
+ my $query=qq{SELECT * FROM borrowers WHERE cardnumber=?};
+ my $sth=$dbh->prepare($query);
+ $sth->execute($infl);
+ my %results = $sth->fetchrow_hashref();
+ if ( $sth->rows != 0 )
+ {
+ return 0;
+ }
+ }
+ if (C4::Context->preference("checkdigit") eq "none") {
+ return 1;
+ }
+
+ my @weightings = (8,4,6,3,5,2,1);
+ my $sum;
+ my $i = 1;
+ my $valid = 0;
+
+ foreach $i (1..7) {
+ my $temp1 = $weightings[$i-1];
+ my $temp2 = substr($infl,$i,1);
+ $sum += $temp1 * $temp2;
+ }
+ my $rem = ($sum%11);
+ if ($rem == 10) {
+ $rem = "X";
+ }
+ if ($rem eq substr($infl,8,1)) {
+ $valid = 1;
+ }
+ return $valid;
+} # sub checkdigit
+
+=item checkvalidisbn
+
+ $valid = &checkvalidisbn($isbn);
+
+Returns a true value iff C<$isbn> is a valid ISBN: it must be ten
+digits long (counting "X" as a digit), and must have a valid check
+digit at the end.
+
+=cut
+#'
+#--------------------------------------
+# Determine if a number is a valid ISBN number, according to length
+# of 10 digits and valid checksum
+sub checkvalidisbn {
+ use strict;
+ my ($q)=@_ ; # Input: ISBN number
+
+ my $isbngood = 0; # Return: true or false
+
+ $q=~s/x$/X/g; # upshift lower case X
+ $q=~s/[^X\d]//g;
+ $q=~s/X.//g;
+
+ #return 0 if $q is not ten digits long
+ if (length($q)!=10) {
+ return 0;
+ }
+
+ #If we get to here, length($q) must be 10
+ my $checksum=substr($q,9,1);
+ my $isbn=substr($q,0,9);
+ my $i;
+ my $c=0;
+ for ($i=0; $i<9; $i++) {
+ my $digit=substr($q,$i,1);
+ $c+=$digit*(10-$i);
+ }
+ $c %= 11;
+ ($c==10) && ($c='X');
+ $isbngood = $c eq $checksum;
+ return $isbngood;
+
+} # sub checkvalidisbn
+
+=item buildCGISort
+
+ $CGIScrollingList = &BuildCGISort($name string, $input_name string);
+
+Returns the scrolling list with name $input_name, built on authorised Values named $name.
+Returns NULL if no authorised values found
+
+=cut
+sub buildCGIsort {
+ use strict;
+ my ($name,$input_name,$data) = @_;
+ my $dbh=C4::Context->dbh;
+ my $query=qq{SELECT * FROM authorised_values WHERE category=? order by lib};
+ my $sth=$dbh->prepare($query);
+ $sth->execute($name);
+ my $CGISort;
+ if ($sth->rows>0){
+ my @values;
+ my %labels;
+ for (my $i =0;$i<=$sth->rows;$i++){
+ my $results = $sth->fetchrow_hashref;
+ push @values, $results->{authorised_value};
+ $labels{$results->{authorised_value}}=$results->{lib};
+ }
+ $CGISort= CGI::scrolling_list(
+ -name => $input_name,
+ -values => \@values,
+ -labels => \%labels,
+ -default=> $data,
+ -size => 1,
+ -multiple => 0);
+ }
+ $sth->finish;
+ return $CGISort;
+}
+END { } # module clean-up code here (global destructor)
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Koha.pm
===================================================================
RCS file: Koha.pm
diff -N Koha.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Koha.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,961 @@
+package C4::Koha;
+
+# 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: Koha.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Biblio;
+use CGI;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+=head1 NAME
+
+C4::Koha - Perl Module containing convenience functions for Koha scripts
+
+=head1 SYNOPSIS
+
+ use C4::Koha;
+
+
+=head1 DESCRIPTION
+
+Koha.pm provides many functions for Koha scripts.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &subfield_is_koha_internal_p
+ &GetBranches &getbranch &getbranchdetail
+ &getprinters &getprinter
+ &GetItemTypes &getitemtypeinfo &ItemType
+ 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
+ &getFacets
+
+ $DEBUG);
+
+use vars qw();
+
+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;
+}
+
+
+=head3 in TEMPLATE
+ <select name="branch">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="branchloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="branchname" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
+
+=cut
+
+sub 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;
+
+ return($branchname);
+}
+
+=head2 getallbranches
+
+ @branches = &GetallBranches();
+ returns informations about ALL branches.
+ Create a branch selector with the following code
+ IndependantBranches Insensitive...
+
+
+=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;
+ }
+ 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
+
+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 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);
+}
+
+=head2 GetItemTypes
+
+ $itemtypes = &GetItemTypes();
+
+Returns information about existing itemtypes.
+
+build a HTML select with the following code :
+
+=head3 in PERL SCRIPT
+
+my $itemtypes = GetItemTypes;
+my @itemtypesloop;
+foreach my $thisitemtype (sort keys %$itemtypes) {
+ my $selected = 1 if $thisitemtype eq $itemtype;
+ my %row =(value => $thisitemtype,
+ selected => $selected,
+ description => $itemtypes->{$thisitemtype}->{'description'},
+ );
+ push @itemtypesloop, \%row;
+}
+$template->param(itemtypeloop => \@itemtypesloop);
+
+=head3 in TEMPLATE
+
+<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
+ <select name="itemtype">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="itemtypeloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
+ <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
+ <input type="submit" value="OK" class="button">
+</form>
+
+
+=cut
+
+sub GetItemTypes {
+# 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);
+ $sth->execute;
+ while (my $IT=$sth->fetchrow_hashref) {
+ $itemtypes{$IT->{'itemtype'}}=$IT;
+ }
+ return (\%itemtypes);
+}
+
+# FIXME this function is better and should replace GetItemTypes everywhere
+sub get_itemtypeinfos_of {
+ my @itemtypes = @_;
+
+ my $query = '
+SELECT itemtype,
+ description,
+ notforloan
+ FROM itemtypes
+ WHERE itemtype IN ('.join(',', map({"'".$_."'"} @itemtypes)).')
+';
+
+ return get_infos_of($query, 'itemtype');
+}
+
+sub ItemType {
+ my ($type)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select description from itemtypes where itemtype=?");
+ $sth->execute($type);
+ my $dat=$sth->fetchrow_hashref;
+ $sth->finish;
+ return ($dat->{'description'});
+}
+=head2 getauthtypes
+
+ $authtypes = &getauthtypes();
+
+Returns information about existing authtypes.
+
+build a HTML select with the following code :
+
+=head3 in PERL SCRIPT
+
+my $authtypes = getauthtypes;
+my @authtypesloop;
+foreach my $thisauthtype (keys %$authtypes) {
+ my $selected = 1 if $thisauthtype eq $authtype;
+ my %row =(value => $thisauthtype,
+ selected => $selected,
+ authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
+ );
+ push @authtypesloop, \%row;
+}
+$template->param(itemtypeloop => \@itemtypesloop);
+
+=head3 in TEMPLATE
+
+<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
+ <select name="authtype">
+ <!-- TMPL_LOOP name="authtypeloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
+ <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
+ <input type="submit" value="OK" class="button">
+</form>
+
+
+=cut
+
+sub getauthtypes {
+# 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");
+ $sth->execute;
+ while (my $IT=$sth->fetchrow_hashref) {
+ $authtypes{$IT->{'authtypecode'}}=$IT;
+ }
+ return (\%authtypes);
+}
+
+sub getauthtype {
+ my ($authtypecode) = @_;
+# 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=?");
+ $sth->execute($authtypecode);
+ my $res=$sth->fetchrow_hashref;
+ return $res;
+}
+
+=head2 getframework
+
+ $frameworks = &getframework();
+
+Returns information about existing frameworks
+
+build a HTML select with the following code :
+
+=head3 in PERL SCRIPT
+
+my $frameworks = frameworks();
+my @frameworkloop;
+foreach my $thisframework (keys %$frameworks) {
+ my $selected = 1 if $thisframework eq $frameworkcode;
+ my %row =(value => $thisframework,
+ selected => $selected,
+ description => $frameworks->{$thisframework}->{'frameworktext'},
+ );
+ push @frameworksloop, \%row;
+}
+$template->param(frameworkloop => \@frameworksloop);
+
+=head3 in TEMPLATE
+
+<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
+ <select name="frameworkcode">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="frameworkloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
+ <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
+ <input type="submit" value="OK" class="button">
+</form>
+
+
+=cut
+
+sub getframeworks {
+# 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");
+ $sth->execute;
+ while (my $IT=$sth->fetchrow_hashref) {
+ $itemtypes{$IT->{'frameworkcode'}}=$IT;
+ }
+ return (\%itemtypes);
+}
+=head2 getframeworkinfo
+
+ $frameworkinfo = &getframeworkinfo($frameworkcode);
+
+Returns information about an frameworkcode.
+
+=cut
+
+sub getframeworkinfo {
+ my ($frameworkcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select * from biblios_framework where frameworkcode=?");
+ $sth->execute($frameworkcode);
+ my $res = $sth->fetchrow_hashref;
+ return $res;
+}
+
+
+=head2 getitemtypeinfo
+
+ $itemtype = &getitemtype($itemtype);
+
+Returns information about an itemtype.
+
+=cut
+
+sub getitemtypeinfo {
+ my ($itemtype) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
+ $sth->execute($itemtype);
+ my $res = $sth->fetchrow_hashref;
+
+ $res->{imageurl} = getitemtypeimagesrcfromurl($res->{imageurl});
+
+ return $res;
+}
+
+sub getitemtypeimagesrcfromurl {
+ my ($imageurl) = @_;
+
+ if (defined $imageurl and $imageurl !~ m/^http/) {
+ $imageurl =
+ getitemtypeimagesrc()
+ .'/'.$imageurl
+ ;
+ }
+
+ return $imageurl;
+}
+
+sub getitemtypeimagedir {
+ return
+ C4::Context->intrahtdocs
+ .'/'.C4::Context->preference('template')
+ .'/itemtypeimg'
+ ;
+}
+
+sub getitemtypeimagesrc {
+ return
+ '/intranet-tmpl'
+ .'/'.C4::Context->preference('template')
+ .'/itemtypeimg'
+ ;
+}
+
+=head2 getprinters
+
+ $printers = &getprinters($env);
+ @queues = keys %$printers;
+
+Returns information about existing printer queues.
+
+C<$env> is ignored.
+
+C<$printers> is a reference-to-hash whose keys are the print queues
+defined in the printers table of the Koha database. The values are
+references-to-hash, whose keys are the fields in the printers table.
+
+=cut
+
+sub getprinters {
+ my ($env) = @_;
+ my %printers;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select * from printers");
+ $sth->execute;
+ while (my $printer=$sth->fetchrow_hashref) {
+ $printers{$printer->{'printqueue'}}=$printer;
+ }
+ 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);
+
+Given the branch code, the function returns the corresponding
+branch name for a comprehensive information display
+
+=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
+ my $printer = $query->param('printer');
+ ($printer) || ($printer = $query->cookie('printer')) || ($printer='');
+ ($printers->{$printer}) || ($printer = (keys %$printers)[0]);
+ return $printer;
+}
+
+=item getalllanguages
+
+ (@languages) = &getalllanguages($type);
+ (@languages) = &getalllanguages($type,$theme);
+
+Returns an array of all available languages.
+
+=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=~ /images$/;
+ 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=~ /images$/;
+ 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=~ /images$/;
+ 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=~ /images$/;
+ 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=~ /images$/;
+ 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=~ /images$/;
+ 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;
+ }
+}
+
+=item getallthemes
+
+ (@themes) = &getallthemes('opac');
+ (@themes) = &getallthemes('intranet');
+
+Returns an array of all available themes.
+
+=cut
+
+sub getallthemes {
+ my $type=shift;
+ my $htdocs;
+ my @themes;
+ if ($type eq 'intranet') {
+ $htdocs=C4::Context->config('intrahtdocs');
+ } else {
+ $htdocs=C4::Context->config('opachtdocs');
+ }
+ opendir D, "$htdocs";
+ 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)
+ {
+ return();
+ }
+ else{
+ unshift (@id ,"");
+ return(\@id,\%city);
+ }
+}
+
+
+=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 $sth=$dbh->prepare("Select roadtypeid,road_type from roadtype order by road_type ");
+ $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 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 = @_;
+
+ my $query = '
+SELECT branchcode,
+ branchname
+ FROM branches
+ WHERE branchcode IN ('.join(',', map({"'".$_."'"} @branchcodes)).')
+';
+ return get_infos_of($query, 'branchcode');
+}
+
+=head2 get_notforloan_label_of
+
+ my $notforloan_label_of = get_notforloan_label_of();
+
+Each authorised value of notforloan (information available in items and
+itemtypes) is link to a single label.
+
+Returns a href where keys are authorised values and values are corresponding
+labels.
+
+ foreach my $authorised_value (keys %{$notforloan_label_of}) {
+ printf(
+ "authorised_value: %s => %s\n",
+ $authorised_value,
+ $notforloan_label_of->{$authorised_value}
+ );
+ }
+
+=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
+ LIMIT 0, 1
+';
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my ($statuscode) = $sth->fetchrow_array();
+
+ $query = '
+SELECT lib,
+ authorised_value
+ FROM authorised_values
+ WHERE category = ?
+';
+ $sth = $dbh->prepare($query);
+ $sth->execute($statuscode);
+ my %notforloan_label_of;
+ while (my $row = $sth->fetchrow_hashref) {
+ $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
+ }
+ $sth->finish;
+
+ return \%notforloan_label_of;
+}
+
+=head2 get_infos_of
+
+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.
+
+ 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};
+
+ # specific information, href of scalar
+ my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
+ print $barcode_of_item->{$itemnumber};
+
+=cut
+sub get_infos_of {
+ my ($query, $key_name, $value_name) = @_;
+
+ my $dbh = C4::Context->dbh;
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+
+ my %infos_of;
+ while (my $row = $sth->fetchrow_hashref) {
+ if (defined $value_name) {
+ $infos_of{ $row->{$key_name} } = $row->{$value_name};
+ }
+ else {
+ $infos_of{ $row->{$key_name} } = $row;
+ }
+ }
+ $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;
+}
+
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Team
+
+=cut
Index: Labels.pm
===================================================================
RCS file: Labels.pm
diff -N Labels.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Labels.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,457 @@
+package C4::Labels;
+
+# Copyright 2006 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
+
+use strict;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+#use Data::Dumper;
+use PDF::Reuse;
+
+
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Labels - Functions for printing spine labels and barcodes in Koha
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &get_label_options &get_label_items
+ &build_circ_barcode &draw_boundaries
+ &draw_box
+);
+
+=item get_label_options;
+
+ $options = get_label_options()
+
+
+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;
+ my $query2 = " SELECT * FROM labels_conf LIMIT 1 ";
+ my $sth = $dbh->prepare($query2);
+ $sth->execute();
+ my $conf_data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $conf_data;
+}
+
+=item get_label_items;
+
+ $options = get_label_items()
+
+
+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;
+
+ # get the actual items to be printed.
+ my @data;
+ my $query3 = " Select * from labels ";
+ my $sth = $dbh->prepare($query3);
+ $sth->execute();
+ my @resultsloop;
+ my $cnt = $sth->rows;
+ my $i1 = 1;
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ # lets get some summary info from each item
+ my $query1 =
+ " select * from biblio, biblioitems, items where itemnumber = ? and
+ items.biblioitemnumber=biblioitems.biblioitemnumber and
+ biblioitems.biblionumber=biblio.biblionumber";
+
+ my $sth1 = $dbh->prepare($query1);
+ $sth1->execute( $data->{'itemnumber'} );
+ my $data1 = $sth1->fetchrow_hashref();
+
+ push( @resultsloop, $data1 );
+ $sth1->finish;
+
+ $i1++;
+ }
+ $sth->finish;
+ return @resultsloop;
+}
+
+=item build_circ_barcode;
+
+ build_circ_barcode( $x_pos, $y_pos, $barcode,
+ $barcodetype, \$item);
+
+$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;
+
+ if ( $barcodetype eq 'EAN13' ) {
+
+ #testing EAN13 barcodes hack
+ $value = $value . '000000000';
+ $value =~ s/-//;
+ $value = substr( $value, 0, 12 );
+
+ #warn $value;
+ eval {
+ PDF::Reuse::Barcode::EAN13(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+
+ # prolong => 2.96,
+ # xSize => 1.5,
+
+ # ySize => 1.2,
+
+# added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
+# i think its embedding extra fonts in the pdf file.
+# mode => 'graphic',
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "EAN13BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ 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,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "CODE39BARCODE $value FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+
+ elsif ( $barcodetype eq 'Matrix2of5' ) {
+
+ #warn "MATRIX ELSE:";
+
+ #testing MATRIX25 barcodes hack
+ # $value = $value.'000000000';
+ $value =~ s/-//;
+
+ # $value = substr( $value, 0, 12 );
+ #warn $value;
+
+ eval {
+ PDF::Reuse::Barcode::Matrix2of5(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+
+ # prolong => 2.96,
+ # xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+
+ elsif ( $barcodetype eq 'EAN8' ) {
+
+ #testing ean8 barcodes hack
+ $value = $value . '000000000';
+ $value =~ s/-//;
+ $value = substr( $value, 0, 8 );
+
+ #warn $value;
+
+ #warn "EAN8 ELSEIF";
+ eval {
+ PDF::Reuse::Barcode::EAN8(
+ x => ( $x_pos_circ + 42 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+
+ elsif ( $barcodetype eq 'UPC-E' ) {
+ eval {
+ PDF::Reuse::Barcode::UPCE(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ elsif ( $barcodetype eq 'NW7' ) {
+ eval {
+ PDF::Reuse::Barcode::NW7(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ elsif ( $barcodetype eq 'ITF' ) {
+ eval {
+ PDF::Reuse::Barcode::ITF(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ elsif ( $barcodetype eq 'Industrial2of5' ) {
+ eval {
+ PDF::Reuse::Barcode::Industrial2of5(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ elsif ( $barcodetype eq 'IATA2of5' ) {
+ eval {
+ PDF::Reuse::Barcode::IATA2of5(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+
+ elsif ( $barcodetype eq 'COOP2of5' ) {
+ eval {
+ PDF::Reuse::Barcode::COOP2of5(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+ elsif ( $barcodetype eq 'UPC-A' ) {
+
+ eval {
+ PDF::Reuse::Barcode::UPCA(
+ x => ( $x_pos_circ + 27 ),
+ y => ( $y_pos + 15 ),
+ value => $value,
+ prolong => 2.96,
+ xSize => 1.5,
+
+ # ySize => 1.2,
+ );
+ };
+ if ($@) {
+ $item->{'barcodeerror'} = 1;
+ #warn "BARCODE FAILED:$@";
+ }
+
+ #warn $barcodetype;
+
+ }
+
+}
+
+=item draw_boundaries
+
+ sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
+ $y_pos, $spine_width, $label_height, $circ_width)
+
+This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
+
+=cut
+
+#'
+sub draw_boundaries {
+
+ 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;
+ my $i = 1;
+
+ for ( $i = 1 ; $i <= 8 ; $i++ ) {
+
+ &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
+
+ #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
+ &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
+ &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
+
+ $y_pos = ( $y_pos - $label_height );
+
+ }
+}
+
+=item drawbox
+
+ sub drawbox { $lower_left_x, $lower_left_y,
+ $upper_right_x, $upper_right_y )
+
+this is a low level sub, that draws a pdf box, it is called by draw_boxes
+
+=cut
+
+#'
+sub drawbox {
+ my ( $llx, $lly, $urx, $ury ) = @_;
+
+ my $str = "q\n"; # save the graphic state
+ $str .= "1.0 0.0 0.0 RG\n"; # border color red
+ $str .= "1 1 1 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
+
+ prAdd($str);
+
+}
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Mason James <mason at katipo.co.nz>
+=cut
+
Index: Letters.pm
===================================================================
RCS file: Letters.pm
diff -N Letters.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Letters.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,274 @@
+package C4::Letters;
+
+
+# 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
+
+use strict;
+use Mail::Sendmail;
+use C4::Date;
+use C4::Suggestions;
+use C4::Members;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Letters - Give functions for Letters management
+
+=head1 SYNOPSIS
+
+ use C4::Letters;
+
+=head1 DESCRIPTION
+
+ "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
+ late issues, as well as other tasks like sending a mail to users that have subscribed to a "serial issue alert" (= being warned every time a new issue has arrived at the library)
+
+ Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&GetLetterList &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
+
+=cut
+
+sub GetLetterList {
+ my ($module) = @_;
+ 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;
+ }
+ return @result;
+}
+
+sub getletter {
+ my ($module,$code) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select * from letter where module=? and code=?");
+ $sth->execute($module,$code);
+ my $line = $sth->fetchrow_hashref;
+ return $line;
+}
+
+=head2 addalert
+
+ parameters :
+ - $borrowernumber : the number of the borrower subscribing to the alert
+ - $type : the type of alert.
+ - externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
+
+ create an alert and return the alertid (primary key)
+
+=cut
+
+sub addalert {
+ my ($borrowernumber,$type,$externalid) = @_;
+ my $dbh=C4::Context->dbh;
+ my $sth = $dbh->prepare("insert into alert (borrowernumber, type, externalid) values (?,?,?)");
+ $sth->execute($borrowernumber,$type,$externalid);
+ # get the alert number newly created and return it
+ my $alertid = $dbh->{'mysql_insertid'};
+ return $alertid;
+}
+
+=head2 delalert
+ parameters :
+ - alertid : the alert id
+ deletes the alert
+=cut
+
+sub delalert {
+ my ($alertid)=@_;
+# warn "ALERTID : $alertid";
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("delete from alert where alertid=?");
+ $sth->execute($alertid);
+}
+
+=head2 getalert
+
+ parameters :
+ - $borrowernumber : the number of the borrower subscribing to the alert
+ - $type : the type of alert.
+ - externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
+ all parameters NON mandatory. If a parameter is omitted, the query is done without the corresponding parameter. For example, without $externalid, returns all alerts for a borrower on a topic.
+
+=cut
+
+sub getalert {
+ my ($borrowernumber,$type,$externalid) = @_;
+ my $dbh=C4::Context->dbh;
+ my $query = "select * from alert where";
+ my @bind;
+ if ($borrowernumber) {
+ $query .= " borrowernumber=? and";
+ push @bind,$borrowernumber;
+ }
+ if ($type) {
+ $query .= " type=? and";
+ push @bind,$type;
+ }
+ if ($externalid) {
+ $query .= " externalid=? and";
+ push @bind,$externalid;
+ }
+ $query =~ s/ and$//;
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ my @result;
+ while (my $line = $sth->fetchrow_hashref) {
+ push @result,$line;
+ }
+ return \@result if $#result >=0; # return only if there is one result.
+ return;
+}
+
+=head2 findrelatedto
+ parameters :
+ - $type : the type of alert
+ - $externalid : the id of the "object" to query
+
+ In the table alert, a "id" is stored in the externalid field. This "id" is related to another table, depending on the type of the alert.
+ When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
+ When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
+=cut
+
+sub findrelatedto {
+ my ($type,$externalid) = @_;
+ my $dbh=C4::Context->dbh;
+ my $sth;
+ if ($type eq 'issue') {
+ $sth=$dbh->prepare("select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?");
+ }
+ if ($type eq 'borrower') {
+ $sth=$dbh->prepare("select concat(firstname,' ',surname) from borrowers where borrowernumber=?");
+ }
+ $sth->execute($externalid);
+ my ($result) = $sth->fetchrow;
+ return $result;
+}
+
+=head2 sendalert
+ parameters :
+ - $type : the type of alert
+ - $externalid : the id of the "object" to query
+ - $letter : the letter to send.
+
+ send an alert to all borrowers having put an alert on a given subject.
+
+=cut
+
+sub sendalerts {
+ my ($type,$externalid,$letter)=@_;
+ my $dbh=C4::Context->dbh;
+ if ($type eq 'issue') {
+# warn "sending issues...";
+ my $letter = getletter('serial',$letter);
+ # prepare the letter...
+ # search the biblionumber
+ my $sth=$dbh->prepare("select biblionumber from subscription where subscriptionid=?");
+ $sth->execute($externalid);
+ my ($biblionumber)=$sth->fetchrow;
+ # 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;
+ # parsing biblio information
+ parseletter($letter,'biblio',$biblionumber);
+ parseletter($letter,'biblioitems',$biblionumber);
+ # find the list of borrowers to alert
+ my $alerts = getalert('','issue',$externalid);
+ foreach (@$alerts) {
+ # and parse borrower ...
+ my $innerletter = $letter;
+ my $borinfo = getmember('',$_->{'borrowernumber'});
+ parseletter($innerletter,'borrowers',$_->{'borrowernumber'});
+ # ... then send mail
+ if ($borinfo->{emailaddress}) {
+ my %mail = ( To => $borinfo->{emailaddress},
+ From => $userenv->{emailaddress},
+ Subject => "".$innerletter->{title},
+ Message => "".$innerletter->{content},
+ );
+ sendmail(%mail);
+# warn "sending to $mail{To} From $mail{From} subj $mail{Subject} Mess $mail{Message}";
+ }
+ }
+ }
+}
+
+=head2
+ 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)";
+ my $dbh=C4::Context->dbh;
+ my $sth;
+ if ($table eq 'biblio') {
+ $sth = $dbh->prepare("select * from biblio where biblionumber=?");
+ } elsif ($table eq 'biblioitems') {
+ $sth = $dbh->prepare("select * from biblioitems where biblionumber=?");
+ } elsif ($table eq 'borrowers') {
+ $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
+ } elsif ($table eq 'branches') {
+ $sth = $dbh->prepare("select * from branches where branchcode=?");
+ }
+ $sth->execute($pk);
+ # store the result in an hash
+ my $values = $sth->fetchrow_hashref;
+ # and get all fields from the table
+ $sth = $dbh->prepare("show columns from $table");
+ $sth->execute;
+ while ((my $field) = $sth->fetchrow_array) {
+ my $replacefield="<<$table.$field>>";
+ my $replacedby = $values->{$field};
+# warn "REPLACE $replacefield by $replacedby";
+ $letter->{title} =~ s/$replacefield/$replacedby/g;
+ $letter->{content} =~ s/$replacefield/$replacedby/g;
+ }
+}
+
+END { } # module clean-up code here (global destructor)
Index: Log.pm
===================================================================
RCS file: Log.pm
diff -N Log.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Log.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,202 @@
+package C4::Log; #assumes C4/Log
+
+#package to deal with Logging Actions in DB
+
+
+# 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
+
+use strict;
+use C4::Context;
+use C4::Date;
+
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Log - Koha Log Facility functions
+
+=head1 SYNOPSIS
+
+ use C4::Log;
+
+=head1 DESCRIPTION
+
+The functions in this module perform various functions in order to log all the operations done on the Database, including deleting and undeleting books, adding/editing members, etc.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&logaction &logstatus &displaylog);
+
+=item logaction
+
+ &logaction($usernumber, $modulename, $actionname, $infos);
+
+Adds a record into action_logs table to report the different changes upon the database
+
+=cut
+#'
+sub logaction{
+ my ($usernumber,$modulename, $actionname, $objectnumber, $infos)=@_;
+ $usernumber='' unless $usernumber;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Insert into action_logs (timestamp,user,module,action,object,info) values (now(),?,?,?,?,?)");
+ $sth->execute($usernumber,$modulename,$actionname,$objectnumber,$infos);
+ $sth->finish;
+}
+
+=item logstatus
+
+ &logstatus;
+
+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");
+}
+
+=item displaylog
+
+ &displaylog($modulename, @filters);
+ $modulename is the name of the module on which the user wants to display logs
+ @filters is an optional table of hash containing :
+ - name : the name of the variable to filter
+ - value : the value of the filter.... May be with * joker
+
+returns a table of hash containing who did what on which object at what time
+
+=cut
+#'
+sub displaylog{
+ my ($modulename, @filters)=@_;
+ my $dbh = C4::Context->dbh;
+ my $strsth;
+ if ($modulename eq "cataloguing"){
+ $strsth="select action_logs.timestamp, action_logs.action, action_logs.info, borrowers.cardnumber, borrowers.surname, borrowers.firstname, borrowers.userid,";
+ $strsth .= "biblio.biblionumber, biblio.title, biblio.author" ;#if ($modulename eq "acqui.simple");
+ $strsth .= " FROM borrowers,action_logs ";
+ $strsth .= ",biblio " ;#if ($modulename eq "acqui.simple");
+
+ $strsth .=" WHERE borrowers.borrowernumber=action_logs.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/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND biblio.title like ".$filter->{value};
+ }elsif ($filter->{name} =~ /author/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND biblio.author like ".$filter->{value};
+ }
+ }
+ }
+ } elsif ($modulename eq "circulation") {
+ $strsth="select a.timestamp, a.action, a.info,a.object, b.cardnumber, b.surname, b.firstname, bi.biblionumber, bi.title, bi.author,b2.firstname as first,b2.surname as last FROM action_logs a ";
+
+ $strsth.=" LEFT JOIN borrowers b on b.borrowernumber=a.user ";
+ $strsth.=" LEFT JOIN borrowers b2 on b2.borrowernumber=a.info ";
+ $strsth.=" LEFT JOIN items i on i.barcode=a.object ";
+ $strsth.=" LEFT JOIN biblio bi on bi.biblionumber=i.biblionumber";
+ $strsth .= " WHERE a.module = 'circulation' ";# if ($modulename eq "circulation");
+ 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/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND biblio.title like ".$filter->{value};
+ }elsif ($filter->{name} =~ /action/){
+ $strsth .= " AND a.action= '$filter->{value}'";
+ }elsif ($filter->{name} =~ /from/){
+ $strsth .= " AND a.timestamp> '$filter->{value}'";
+ }elsif ($filter->{name} =~ /to/){
+ $strsth .= " AND a.timestamp<= '$filter->{value}'";
+ }
+ }
+ }
+ } elsif ($modulename eq "members"){
+ $strsth="select a.timestamp, a.action,a.info, a.object, b.surname, b.firstname, ";
+ $strsth .= "bor2.cardnumber as card, bor2.surname as last, bor2.firstname as first, bor2.userid as user";
+ $strsth .= " FROM action_logs a ";
+ $strsth.=" LEFT JOIN borrowers b on b.borrowernumber=a.user ";
+ $strsth.=" LEFT JOIN borrowers bor2 on bor2.borrowernumber=a.object ";
+ $strsth .= " WHERE a.module = 'members' ";# if ($modulename eq "acqui.simple");
+ if (@filters){
+ foreach my $filter (@filters){
+ if ($filter->{name} =~ /user/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND b.surname like ".$filter->{value};
+ }elsif ($filter->{name} =~ /surname/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND bor2.surname like ".$filter->{value};
+ }elsif ($filter->{name} =~ /firstname/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND bor2.firsntame like ".$filter->{value};
+ }elsif ($filter->{name} =~ /cardnumber/){
+ $filter->{value}=~s/\*/%/g;
+ $strsth .= " AND bor2.cardnumber like ".$filter->{value};
+ }elsif ($filter->{name} =~ /action/){
+ $strsth .= " AND a.action= '$filter->{value}'";
+ }
+ }
+ }
+ }
+# warn "displaylog :".$strsth;
+ if ($strsth){
+ my $sth=$dbh->prepare($strsth);
+ $sth->execute;
+ my @results;
+ my $count;
+ my $hilighted=1;
+ while (my $data = $sth->fetchrow_hashref){
+ $data->{hilighted} = ($hilighted>0);
+ $data->{info} =~ s/\n/<br\/>/g;
+ $data->{day} = format_date($data->{timestamp});
+ push @results, $data;
+ $count++;
+ $hilighted = -$hilighted;
+ }
+ return ($count, \@results);
+ } else {return 0;}
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Members.pm
===================================================================
RCS file: Members.pm
diff -N Members.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Members.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,1655 @@
+# -*- tab-width: 8 -*-
+
+package C4::Members;
+
+# Copyright 2000-2003 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: Members.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 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 vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Members - Perl Module containing convenience functions for member handling
+
+=head1 SYNOPSIS
+
+use C4::Members;
+
+=head1 DESCRIPTION
+
+This module contains routines for adding, modifying and deleting members/patrons/borrowers
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+#'
+
+ at ISA = qw(Exporter);
+
+ at 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
+&patronflags
+ );
+
+
+
+=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);
+}
+
+=item BornameSearch
+
+ ($count, $borrowers) = &BornameSearch($env, $searchstring, $type);
+
+Looks up patrons (borrowers) by name.
+
+C<$env> is ignored.
+
+BUGFIX 499: C<$type> is now used to determine type of search.
+if $type is "simple", search is performed on the first letter of the
+surname only.
+
+C<$searchstring> is a space-separated list of search terms. Each term
+must match the beginning a borrower's surname, first name, or other
+name.
+
+C<&BornameSearch> returns a two-element list. C<$borrowers> is a
+reference-to-array; each element is a reference-to-hash, whose keys
+are the fields of the C<borrowers> table in the Koha database.
+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 $dbh = C4::Context->dbh;
+ my $query = "";
+ my $count;
+ my @data;
+ my @bind=();
+
+ if($type eq "simple") # simple search for one letter only
+ {
+ $query="Select * from borrowers where surname like '$searchstring%' 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)";
+
+ }
+ $query=$query." order by $orderby";
+ }
+
+ 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);
+ }
+ # $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 :
+
+ if $borrower->{flags}->{LOST} {
+ # Patron's card was reported lost
+ }
+
+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 = 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->finish;
+ $borrower->{'flags'}=$flags;
+ $borrower->{'authflags'} = $accessflagshash;
+ return ($borrower); #, $flags, $accessflagshash);
+}
+
+=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
+
+($flags, $homebranch) = GetFlagsAndBranchFromBorrower($loggedinuser);
+
+this function read on the database to get flags and homebranch for a user
+given on input arg.
+
+return :
+it returns the $flags & the homebranch in scalar context.
+
+=back
+
+=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;
+ my $query = "
+ SELECT flags, branchcode
+ FROM borrowers
+ WHERE borrowernumber = ?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($loggedinuser);
+
+ return $sth->fetchrow;
+}
+
+
+sub getmember {
+ my ( $cardnumber, $bornum ) = @_;
+ $cardnumber = uc $cardnumber;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ( $bornum eq '' ) {
+ $sth = $dbh->prepare("Select * from borrowers where cardnumber=?");
+ $sth->execute($cardnumber);
+ } else {
+ $sth = $dbh->prepare("Select * from borrowers where borrowernumber=?");
+ $sth->execute($bornum);
+ }
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ if ($data) {
+ return ($data);
+ }
+ else { # try with firstname
+ if ($cardnumber) {
+ my $sth =
+ $dbh->prepare("select * from borrowers where firstname=?");
+ $sth->execute($cardnumber);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return ($data);
+ }
+ }
+ return undef;
+}
+
+=item borrdata
+
+ $borrower = &borrdata($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<&borrdata> returns a reference-to-hash whose keys are the fields of
+the C<borrowers> table in the Koha database.
+
+=cut
+
+#'
+sub borrdata {
+ my ( $cardnumber, $bornum ) = @_;
+ $cardnumber = uc $cardnumber;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ( $bornum eq '' ) {
+ $sth =
+ $dbh->prepare(
+"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where cardnumber=?"
+ );
+ $sth->execute($cardnumber);
+ }
+ else {
+ $sth =
+ $dbh->prepare(
+"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where borrowernumber=?"
+ );
+ $sth->execute($bornum);
+ }
+ my $data = $sth->fetchrow_hashref;
+# warn "DATA" . $data->{category_type};
+ $sth->finish;
+ if ($data) {
+ return ($data);
+ }
+ else { # try with firstname
+ if ($cardnumber) {
+ my $sth =
+ $dbh->prepare(
+"Select borrowers.*,categories.category_type from borrowers left join categories on borrowers.categorycode=categories.categorycode where firstname=?"
+ );
+ $sth->execute($cardnumber);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return ($data);
+ }
+ }
+ return undef;
+}
+
+=item borrdata2
+
+ ($borrowed, $due, $fine) = &borrdata2($env, $borrowernumber);
+
+Returns aggregate data about items borrowed by the patron with the
+given borrowernumber.
+
+C<$env> is ignored.
+
+C<&borrdata2> returns a three-element array. C<$borrowed> is the
+number of books the patron currently has borrowed. C<$due> is the
+number of overdue items the patron currently has borrowed. C<$fine> is
+the total fine currently due by the borrower.
+
+=cut
+
+#'
+sub borrdata2 {
+ my ( $env, $bornum ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "Select count(*) from issues where borrowernumber='$bornum' and
+ returndate is NULL";
+
+ # print $query;
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ $sth = $dbh->prepare(
+ "Select count(*) from issues where
+ borrowernumber='$bornum' 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'"
+ );
+ $sth->execute;
+ my $data3 = $sth->fetchrow_hashref;
+ $sth->finish;
+
+ return ( $data2->{'count(*)'}, $data->{'count(*)'},
+ $data3->{'sum(amountoutstanding)'} );
+}
+
+sub modmember {
+ my (%data) = @_;
+ my $dbh = C4::Context->dbh;
+ $data{'dateofbirth'}=format_date_in_iso($data{'dateofbirth'});
+
+
+ $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'} );
+
+ }
+
+ 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;
+ $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'){
+ # is adult check guarantees;
+ updateguarantees(%data);
+ }
+}
+
+sub newmember {
+ my (%data) = @_;
+ my $dbh = C4::Context->dbh;
+ $data{'dateofbirth'}=format_date_in_iso($data{'dateofbirth'});
+
+
+ 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);
+ $sth->execute;
+ $sth->finish;
+ $data{'bornum'} =$dbh->{'mysql_insertid'};
+ return $data{'bornum'};
+}
+
+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);
+
+}
+
+=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;
+
+}
+sub getmemberfromuserid {
+ my ($userid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select * from borrowers where userid=?");
+ $sth->execute($userid);
+ return $sth->fetchrow_hashref;
+}
+sub updateguarantees {
+ my (%data) = @_;
+ my $dbh = C4::Context->dbh;
+ my ( $count, $guarantees ) = findguarantees( $data{'borrowernumber'} );
+ for ( my $i = 0 ; $i < $count ; $i++ ) {
+
+ # FIXME
+ # 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 $sth3 = $dbh->prepare($guaquery);
+ $sth3->execute;
+ $sth3->finish;
+ }
+}
+################################################################################
+
+=item fixup_cardnumber
+
+Warning: The caller is responsible for locking the members table in write
+mode, to avoid database corruption.
+
+=cut
+
+use vars qw( @weightings );
+my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
+
+sub fixup_cardnumber {
+ 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".
+
+ # if ($cardnumber !~ /\S/ && $autonumber_members) {
+ if ($autonumber_members) {
+ my $dbh = C4::Context->dbh;
+ if ( C4::Context->preference('checkdigit') eq 'katipo' ) {
+
+ # if checkdigit is selected, calculate katipo-style cardnumber.
+ # otherwise, just use the max()
+ # 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.
+ my $sth =
+ $dbh->prepare(
+ "select max(substring(borrowers.cardnumber,2,7)) from borrowers"
+ );
+ $sth->execute;
+
+ 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 {
+ $cardnumber += 1;
+ }
+
+ my $sum = 0;
+ for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
+
+ # read weightings, left to right, 1 char at a time
+ my $temp1 = $weightings[$i];
+
+ # sequence left to right, 1 char at a time
+ my $temp2 = substr( $cardnumber, $i, 1 );
+
+ # mult each char 1-7 by its corresponding weighting
+ $sum += $temp1 * $temp2;
+ }
+
+ $rem = ( $sum % 11 );
+ $rem = 'X' if $rem == 10;
+
+ $cardnumber = "V$cardnumber$rem";
+ }
+ else {
+
+ # MODIFIED BY JF: mysql4.1 allows casting as an integer, which is probably
+ # better. I'll leave the original in in case it needs to be changed for you
+ my $sth =
+ $dbh->prepare(
+ "select max(cast(cardnumber as signed)) from borrowers");
+
+ #my $sth=$dbh->prepare("select max(borrowers.cardnumber) from borrowers");
+
+ $sth->execute;
+
+ $cardnumber="V$cardnumber$rem";
+ }
+ 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;
+
+ my $data=$sth->fetchrow_hashref;
+ $cardnumber=$data->{'max(borrowers.cardnumber)'};
+ $sth->finish;
+
+ # 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.
+
+ 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;
+ }
+
+
+ }
+ return $cardnumber;
+}
+
+=item GuarantornameSearch
+
+ ($count, $borrowers) = &GuarantornameSearch($env, $searchstring, $type);
+
+Looks up guarantor by name.
+
+C<$env> is ignored.
+
+BUGFIX 499: C<$type> is now used to determine type of search.
+if $type is "simple", search is performed on the first letter of the
+surname only.
+
+C<$searchstring> is a space-separated list of search terms. Each term
+must match the beginning a borrower's surname, first name, or other
+name.
+
+C<&GuarantornameSearch> returns a two-element list. C<$borrowers> is a
+reference-to-array; each element is a reference-to-hash, whose keys
+are the fields of the C<borrowers> table in the Koha database.
+C<$count> is the number of elements in C<$borrowers>.
+
+return all info from guarantor =>only category_type A
+
+=cut
+
+#'
+#used by member enquiries from the intranet
+#called by guarantor_search.pl
+sub GuarantornameSearch {
+ my ( $env, $searchstring, $orderby, $type ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "";
+ my $count;
+ my @data;
+ my @bind = ();
+
+ if ( $type eq "simple" ) # simple search for one letter only
+ {
+ $query =
+"Select * from borrowers,categories where borrowers.categorycode=categories.categorycode and category_type='A' and surname like ? order by $orderby";
+ @bind = ("$searchstring%");
+ }
+ else # advanced search looking in surname, firstname and othernames
+ {
+ @data = split( ' ', $searchstring );
+ $count = @data;
+ $query = "Select * from borrowers,categories
+ where ((surname like ? or surname like ?
+ or firstname like ? or firstname like ?
+ or othernames like ? or othernames like ?) and borrowers.categorycode=categories.categorycode and category_type='A'
+ ";
+ @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 . ") or cardnumber like ?
+ order by $orderby";
+ push( @bind, $searchstring );
+
+ # FIXME - .= <<EOT;
+ }
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@bind);
+ my @results;
+ my $cnt = $sth->rows;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
+ }
+
+ # $sth->execute;
+ $sth->finish;
+ return ( $cnt, \@results );
+}
+
+
+=item findguarantees
+
+ ($num_children, $children_arrayref) = &findguarantees($parent_borrno);
+ $child0_cardno = $children_arrayref->[0]{"cardnumber"};
+ $child0_borrno = $children_arrayref->[0]{"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).
+
+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 ($bornum)=@_;
+ 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;
+ }
+ $sth->finish;
+ return (scalar(@dat), \@dat);
+}
+
+=item 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 ($bornum)=@_;
+ 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;
+ $sth->finish;
+ return($data);
+}
+
+sub borrowercard_active {
+ my ($bornum) = @_;
+ 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');
+ }
+}
+
+# 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";
+ }
+ }
+ closedir(DIR);
+ return "http://cc.neu.edu.tr/stdpictures/".$cardnumber.".jpg";
+}
+
+sub change_user_pass {
+ 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 * 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;
+ }
+
+}
+
+=head2 checkuniquemember (OUEST-PROVENCE)
+
+ $result = &checkuniquemember($collectivity,$surname,$categorycode,$firstname,$dateofbirth);
+
+Checks that a member exists or not in the database.
+
+C<&result> is 1 (=exist) or 0 (=does not exist)
+C<&collectivity> is 1 (= we add a collectivity) or 0 (= we add a physical member)
+C<&surname> is the surname
+C<&categorycode> is from categorycode table
+C<&firstname> is the firstname (only if collectivity=0)
+C<&dateofbirth> is the date of birth (only if collectivity=0)
+
+=cut
+sub checkuniquemember {
+ my ( $collectivity, $surname, $firstname, $dateofbirth ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $request;
+ if ($collectivity) {
+
+# $request="select count(*) from borrowers where surname=? and categorycode=?";
+ $request =
+ "select borrowernumber,categorycode from borrowers where surname=? ";
+ }
+ else {
+
+# $request="select count(*) from borrowers where surname=? and categorycode=? and firstname=? and dateofbirth=?";
+ $request =
+"select borrowernumber,categorycode from borrowers where surname=? and firstname=? and dateofbirth=?";
+ }
+ my $sth = $dbh->prepare($request);
+ if ($collectivity) {
+ $sth->execute( uc($surname) );
+ }
+ else {
+ $sth->execute( uc($surname), ucfirst($firstname), $dateofbirth );
+ }
+ my @data = $sth->fetchrow;
+ if ( $data[0] ) {
+ $sth->finish;
+ return $data[0], $data[1];
+
+ #
+ }
+ else {
+ $sth->finish;
+ return 0;
+ }
+}
+=head2 getzipnamecity (OUEST-PROVENCE)
+
+take all info from table city for the fields city and zip
+check for the name and the zip code of the city selected
+
+=cut
+
+sub getzipnamecity {
+ my ($cityid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "select city_name,city_zipcode from cities where cityid=? ");
+ $sth->execute($cityid);
+ my @data = $sth->fetchrow;
+ return $data[0], $data[1];
+}
+
+=head2 updatechildguarantor (OUEST-PROVENCE)
+
+check for title,firstname,surname,adress,zip code and city from guarantor to
+guarantorchild
+
+=cut
+
+#'
+
+sub getguarantordata {
+ my ($borrowerid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"Select title,firstname,surname,streetnumber,address,streettype,address2,zipcode,city,phone,phonepro,mobile,email,emailpro,fax from borrowers where borrowernumber =? "
+ );
+ $sth->execute($borrowerid);
+ my $guarantor_data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $guarantor_data;
+}
+
+=head2 getdcity (OUEST-PROVENCE)
+recover cityid with city_name condition
+=cut
+
+sub getidcity {
+ my ($city_name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select cityid from cities where city_name=? ");
+ $sth->execute($city_name);
+ my $data = $sth->fetchrow;
+ return $data;
+}
+
+=head2 getcategorytype (OUEST-PROVENCE)
+
+check for the category_type with categorycode
+and return the category_type
+
+=cut
+
+sub getcategorytype {
+ my ($categorycode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"Select category_type,description from categories where categorycode=? "
+ );
+ $sth->execute($categorycode);
+ my ( $category_type, $description ) = $sth->fetchrow;
+ return $category_type, $description;
+}
+
+
+
+
+
+
+
+# # A better approach might be to set borrowernumber autoincrement and
+#
+ sub NewBorrowerNumber {
+ 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)'});
+ }
+
+=head2 ethnicitycategories
+
+ ($codes_arrayref, $labels_hashref) = ðnicitycategories();
+
+Looks up the different ethnic types in the database. Returns two
+elements: a reference-to-array, which lists the ethnicity codes, and a
+reference-to-hash, which maps the ethnicity codes to ethnicity
+descriptions.
+
+=cut
+
+#'
+
+sub ethnicitycategories {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("Select code,name from ethnicity order by name");
+ $sth->execute;
+ my %labels;
+ my @codes;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @codes, $data->{'code'};
+ $labels{ $data->{'code'} } = $data->{'name'};
+ }
+ $sth->finish;
+ return ( \@codes, \%labels );
+}
+
+=head2 fixEthnicity
+
+ $ethn_name = &fixEthnicity($ethn_code);
+
+Takes an ethnicity code (e.g., "european" or "pi") and returns the
+corresponding descriptive name from the C<ethnicity> table in the
+Koha database ("European" or "Pacific Islander").
+
+=cut
+
+#'
+
+sub fixEthnicity{
+
+ my $ethnicity = shift;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("Select name from ethnicity where code = ?");
+ $sth->execute($ethnicity);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $data->{'name'};
+} # sub fixEthnicity
+
+
+
+=head2 get_age
+
+ $dateofbirth,$date = &get_age($date);
+
+this function return the borrowers age with the value of dateofbirth
+
+=cut
+#'
+sub get_age {
+ my ($date, $date_ref) = @_;
+
+ if (not defined $date_ref) {
+ $date_ref = get_today();
+ }
+
+ my ($year1, $month1, $day1) = split /-/, $date;
+ my ($year2, $month2, $day2) = split /-/, $date_ref;
+
+ my $age = $year2 - $year1;
+ if ($month1.$day1 > $month2.$day2) {
+ $age--;
+ }
+
+ return $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
+
+#'
+sub get_institutions {
+ my $dbh = C4::Context->dbh();
+ my $sth =
+ $dbh->prepare(
+"SELECT borrowernumber,surname FROM borrowers WHERE categorycode=? ORDER BY surname"
+ );
+ $sth->execute('I');
+ my %orgs;
+ while ( my $data = $sth->fetchrow_hashref() ) {
+ $orgs{ $data->{'borrowernumber'} } = $data;
+ }
+ $sth->finish();
+ return ( \%orgs );
+
+} # sub get_institutions
+
+=head2 add_member_orgs
+
+ add_member_orgs($borrowernumber,$borrowernumbers);
+
+Takes a borrowernumber and a list of other borrowernumbers and inserts them into the borrowers_to_borrowers table
+
+=cut
+
+#'
+sub add_member_orgs {
+ my ( $borrowernumber, $otherborrowers ) = @_;
+ my $dbh = C4::Context->dbh();
+ my $query =
+ "INSERT INTO borrowers_to_borrowers (borrower1,borrower2) VALUES (?,?)";
+ my $sth = $dbh->prepare($query);
+ foreach my $bornum (@$otherborrowers) {
+ $sth->execute( $borrowernumber, $bornum );
+ }
+ $sth->finish();
+
+} # sub add_member_orgs
+
+=head2 GetBorrowersFromSurname
+
+=over 4
+
+\@resutlts = GetBorrowersFromSurname($surname)
+this function get the list of borrower names like $surname.
+return :
+the table of results in @results
+
+=back
+
+=cut
+sub GetBorrowersFromSurname {
+ my ($searchstring)=@_;
+ my $dbh = C4::Context->dbh;
+ $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);
+ $sth->execute("$data[0]%");
+ my @results;
+ my $count = 0;
+ while (my $data=$sth->fetchrow_hashref){
+ push(@results,$data);
+ $count++;
+ }
+ $sth->finish;
+ return ($count,\@results);
+}
+
+=head2 expand_sex_into_predicate
+
+ $data{&expand_sex_into_predicate($data{sex})} = 1;
+
+Converts a single 'M' or 'F' into 'sex_M_p' or 'sex_F_p'
+respectively.
+
+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.
+
+=cut
+
+sub expand_sex_into_predicate {
+ my($sex) = @_;
+ return "sex_${sex}_p";
+} # expand_sex_into_predicate
+
+
+#
+# NOTE!: If you change this function, be sure to update the POD for
+# &getpatroninformation.
+#
+# $flags = &patronflags($env, $patron, $dbh);
+#
+# $flags->{CHARGES}
+# {message} Message showing patron's credit or debt
+# {noissues} Set if patron owes >$5.00
+# {GNA} Set if patron gone w/o address
+# {message} "Borrower has no valid address"
+# {noissues} Set.
+# {LOST} Set if patron's card reported lost
+# {message} Message to this effect
+# {noissues} Set.
+# {DBARRED} Set is patron is debarred
+# {message} Message to this effect
+# {noissues} Set.
+# {NOTES} Set if patron has notes
+# {message} Notes about patron
+# {ODUES} Set if patron has overdue books
+# {message} "Yes"
+# {itemlist} ref-to-array: list of overdue books
+# {itemlisttext} Text list of overdue items
+# {WAITING} Set if there are items available that the
+# patron reserved
+# {message} Message to this effect
+# {itemlist} ref-to-array: list of available items
+sub patronflags {
+# Original subroutine for Circ2.pm
+ my %flags;
+ my ($env, $patroninformation, $dbh) = @_;
+ my $amount = C4::Accounts2::checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
+ if ($amount > 0) {
+ my %flaginfo;
+ my $noissuescharge = C4::Context->preference("noissuescharge");
+ $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
+ if ($amount > $noissuescharge) {
+ $flaginfo{'noissues'} = 1;
+ }
+ $flags{'CHARGES'} = \%flaginfo;
+ } elsif ($amount < 0){
+ my %flaginfo;
+ $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
+ $flags{'CHARGES'} = \%flaginfo;
+ }
+ if ($patroninformation->{'gonenoaddress'} == 1) {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower has no valid address.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'GNA'} = \%flaginfo;
+ }
+ if ($patroninformation->{'lost'} == 1) {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower\'s card reported lost.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'LOST'} = \%flaginfo;
+ }
+ if ($patroninformation->{'debarred'} == 1) {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower is Debarred.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'DBARRED'} = \%flaginfo;
+ }
+ if ($patroninformation->{'borrowernotes'}) {
+ my %flaginfo;
+ $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
+ $flags{'NOTES'} = \%flaginfo;
+ }
+ my ($odues, $itemsoverdue)
+ = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
+ if ($odues > 0) {
+ my %flaginfo;
+ $flaginfo{'message'} = "Yes";
+ $flaginfo{'itemlist'} = $itemsoverdue;
+ foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
+ $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
+ }
+ $flags{'ODUES'} = \%flaginfo;
+ }
+ my ($nowaiting, $itemswaiting)=C4::Reserves2::CheckWaiting($patroninformation->{'borrowernumber'});
+ if ($nowaiting > 0) {
+ my %flaginfo;
+ $flaginfo{'message'} = "Reserved items available";
+ $flaginfo{'itemlist'} = $itemswaiting;
+ $flags{'WAITING'} = \%flaginfo;
+ }
+ return(\%flags);
+}
+
+##Not exported same in Circ2
+sub checkoverdues {
+# From Circ2.pm, added here to prevent recursive inclusion of Circ2
+ #checks whether a borrower has overdue items
+ my ($env, $bornum, $dbh)=@_;
+ my $today=get_today();
+ my @overdueitems;
+ my $count = 0;
+ my $sth = $dbh->prepare("SELECT issues.* , i.biblionumber as biblionumber,b.* FROM issues, items i,biblio b
+ WHERE i.itemnumber=issues.itemnumber
+ AND i.biblionumber=b.biblionumber
+ AND issues.borrowernumber = ?
+ AND issues.returndate is NULL
+ AND issues.date_due < ?");
+ $sth->execute($bornum,$today);
+ while (my $data = $sth->fetchrow_hashref) {
+
+ push (@overdueitems, $data);
+ $count++;
+ }
+ $sth->finish;
+ return ($count, \@overdueitems);
+}
+1;
+__END__
\ No newline at end of file
Index: NewsChannels.pm
===================================================================
RCS file: NewsChannels.pm
diff -N NewsChannels.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ NewsChannels.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,388 @@
+package C4::NewsChannels;
+
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Date;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::NewsChannels - Functions to manage the news channels and its categories
+
+=head1 DESCRIPTION
+
+This module provides the functions needed to admin the news channels and its categories
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &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
+&add_opac_new &upd_opac_new &del_opac_new &get_opac_new &get_opac_news
+ &add_opac_electronic &upd_opac_electronic &del_opac_electronic &get_opac_electronic &get_opac_electronics
+);
+
+
+=item news_channels
+
+ ($count, @channels) = &news_channels($channel_name, $id_category, $unclassified);
+
+Looks up news channels by name or category.
+
+C<$channel_name> is the channel name to search.
+
+C<$id_category> is the channel category code to search.
+
+C<$$unclassified> if it is set and $channel_name and $id_category search for the news channels without a category
+
+if none of the params are set C<&news_channels> returns all the news channels.
+
+C<&news_channels> returns two values: an integer giving the number of
+news channels found and a reference to an array
+of references to hash, which has the news_channels and news_channels_categories fields.
+
+=cut
+
+sub news_channels {
+ my ($channel_name, $id_category, $unclassified) = @_;
+ my $dbh = C4::Context->dbh;
+ my @channels;
+ my $query = "SELECT * FROM news_channels LEFT JOIN news_channels_categories ON news_channels.id_category = news_channels_categories.id_category";
+ if ( ($channel_name ne '') && ($id_category ne '') ) {
+ $query.= " WHERE channel_name like '" . $channel_name . "%' AND news_channels.id_category = " . $id_category;
+ } elsif ($channel_name ne '') {
+ $query.= " WHERE channel_name like '" . $channel_name . "%'";
+ } elsif ($id_category ne '') {
+ $query.= " WHERE news_channels.id_category = " . $id_category;
+ } elsif ($unclassified) {
+ $query.= " WHERE news_channels.id_category IS NULL ";
+ }
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ while (my $row = $sth->fetchrow_hashref) {
+ push @channels, $row;
+ }
+ $sth->finish;
+ return (scalar(@channels), @channels);
+}
+
+=item news_channels_by_category
+
+ ($count, @results) = &news_channels_by_category();
+
+Looks up news channels grouped by category.
+
+C<&news_channels_by_category> returns two values: an integer giving the number of
+categories found and a reference to an array
+of references to hash, which the following keys:
+
+=over 4
+
+=item C<channels_count>
+
+The number of news channels in that category
+
+=item C<channels>
+
+A reference to an array of references to hash which keys are the new_channels fields.
+
+Additionally the last index of results has a reference to all the news channels which don't have a category
+
+=cut
+
+sub news_channels_by_category {
+
+ my ($categories_count, @results) = &news_channels_categories();
+ foreach my $row (@results) {
+
+ my ($channels_count, @channels) = &news_channels('', $row->{'id_category'});
+ $row->{'channels_count'} = $channels_count;
+ $row->{'channels'} = \@channels;
+ }
+
+ my ($channels_count, @channels) = &news_channels('', '', 1);
+ my %row;
+ $row{'id_category'} = -1;
+ $row{'unclassified'} = 1;
+ $row{'channels_count'} = $channels_count;
+ $row{'channels'} = \@channels;
+ push @results, \%row;
+
+ return (scalar(@results), @results);
+}
+
+sub get_new_channel {
+ my ($id) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM news_channels WHERE id = ?");
+ $sth->execute($id);
+ my $channel = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $channel;
+}
+
+sub del_channels {
+ my ($ids) = @_;
+ if ($ids ne '') {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("DELETE FROM news_channels WHERE id IN ($ids) ");
+ $sth->execute();
+ $sth->finish;
+ return $ids;
+ }
+ return 0;
+}
+
+sub add_channel {
+ my ($name, $url, $id_category, $notes) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO news_channels (channel_name, url, id_category, notes) VALUES (?,?,?,?)");
+ $sth->execute($name, $url, $id_category, $notes);
+ $sth->finish;
+ return 1;
+}
+
+sub update_channel {
+ my ($id, $name, $url, $id_category, $notes) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE news_channels SET channel_name = ?, url = ?, id_category = ?, notes = ? WHERE id = ?");
+ $sth->execute($name, $url, $id_category, $notes, $id);
+ $sth->finish;
+ return 1;
+}
+
+sub news_channels_categories {
+ my $dbh = C4::Context->dbh;
+ my @categories;
+ my $query = "SELECT * FROM news_channels_categories";
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ while (my $row = $sth->fetchrow_hashref) {
+ push @categories, $row;
+ }
+ $sth->finish;
+ return (scalar(@categories), @categories);
+
+}
+
+sub get_new_channel_category {
+ my ($id) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM news_channels_categories WHERE id_category = ?");
+ $sth->execute($id);
+ my $category = $sth->fetchrow_hashref;
+ $sth->finish;
+ return $category;
+}
+
+sub del_channels_categories {
+ my ($ids) = @_;
+ if ($ids ne '') {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE news_channels SET id_category = NULL WHERE id_category IN ($ids) ");
+ $sth->execute();
+ $sth = $dbh->prepare("DELETE FROM news_channels_categories WHERE id_category IN ($ids) ");
+ $sth->execute();
+ $sth->finish;
+ return $ids;
+ }
+ return 0;
+}
+
+sub add_channel_category {
+ my ($name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO news_channels_categories (category_name) VALUES (?)");
+ $sth->execute($name);
+ $sth->finish;
+ return 1;
+}
+
+sub update_channel_category {
+ my ($id, $name) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE news_channels_categories SET category_name = ? WHERE id_category = ?");
+ $sth->execute($name, $id);
+ $sth->finish;
+ return 1;
+}
+
+
+sub add_opac_new {
+ my ($title, $new, $lang) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO opac_news (title, new, lang) VALUES (?,?,?)");
+ $sth->execute($title, $new, $lang);
+ $sth->finish;
+ return 1;
+}
+
+sub upd_opac_new {
+ my ($idnew, $title, $new, $lang) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE opac_news SET title = ?, new = ?, lang = ? WHERE idnew = ?");
+ $sth->execute($title, $new, $lang, $idnew);
+ $sth->finish;
+ return 1;
+}
+
+sub del_opac_new {
+ my ($ids) = @_;
+ if ($ids) {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("DELETE FROM opac_news WHERE idnew IN ($ids)");
+ $sth->execute();
+ $sth->finish;
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub get_opac_new {
+ my ($idnew) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM opac_news WHERE idnew = ?");
+ $sth->execute($idnew);
+ my $data = $sth->fetchrow_hashref;
+ $data->{$data->{'lang'}} = 1;
+ $sth->finish;
+ return $data;
+}
+
+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";
+ if ($lang) {
+ $query.= " WHERE lang = '" .$lang ."' ";
+ }
+ $query.= " ORDER BY timestamp DESC ";
+ #if ($limit) {
+ # $query.= "LIMIT 0, " . $limit;
+ #}
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my @opac_news;
+ my $count = 0;
+ while (my $row = $sth->fetchrow_hashref) {
+ if ((($limit) && ($count < $limit)) || (!$limit)) {
+ $row->{'newdate'} = format_date($row->{'newdate'});
+ push @opac_news, $row;
+ }
+ $count++;
+ }
+ return ($count, \@opac_news);
+}
+
+### get electronic databases
+
+sub add_opac_electronic {
+ my ($title, $edata, $lang,$image,$href,$section) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("INSERT INTO opac_electronic (title, edata, lang,image,href,section) VALUES (?,?,?,?,?,?)");
+ $sth->execute($title, $edata, $lang,$image,$href,$section);
+ $sth->finish;
+ return 1;
+}
+
+sub upd_opac_electronic {
+ my ($idelectronic, $title, $edata, $lang, $image, $href,$section) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE opac_electronic SET title = ?, edata = ?, lang = ? , image=?, href=? ,section=? WHERE idelectronic = ?");
+ $sth->execute($title, $edata, $lang, $image,$href ,$section, $idelectronic);
+ $sth->finish;
+ return 1;
+}
+
+sub del_opac_electronic {
+ my ($ids) = @_;
+ if ($ids) {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("DELETE FROM opac_electronic WHERE idelectronic IN ($ids)");
+ $sth->execute();
+ $sth->finish;
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub get_opac_electronic {
+ my ($idelectronic) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM opac_electronic WHERE idelectronic = ?");
+ $sth->execute($idelectronic);
+ my $data = $sth->fetchrow_hashref;
+ $data->{$data->{'lang'}} = 1;
+ $data->{$data->{'section'}} = 1;
+ $sth->finish;
+ return $data;
+}
+
+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";
+ if ($lang) {
+ $query.= " WHERE lang = '" .$lang ."' ";
+ }
+ if ($section) {
+ $query.= " and section= '" . $section."' ";
+ }
+ $query.= " ORDER BY title ";
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute();
+ my @opac_electronic;
+ my $count = 0;
+ while (my $row = $sth->fetchrow_hashref) {
+ $row->{'newdate'}=format_date($row->{'newdate'});
+ push @opac_electronic, $row;
+
+
+ $count++;
+ }
+
+ return ($count,\@opac_electronic);
+}
+1;
+__END__
+=back
+
+=head1 AUTHOR
+
+TG
+
+=cut
+
+
Index: Output.pm
===================================================================
RCS file: Output.pm
diff -N Output.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Output.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,313 @@
+package C4::Output;
+# $Id: Output.pm,v 1.1.2.1 2007/03/10 01:35:34 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.
+#
+# 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
+
+
+use strict;
+require Exporter;
+
+use C4::Context;
+use HTML::Template;
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Output - Functions for managing templates
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at 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/";
+
+#---------------------------------------------------------------------------------------------------------
+# FIXME - POD
+sub gettemplate {
+ my ($tmplbase, $opac, $query) = @_;
+
+if (!$query){
+ warn "no query in gettemplate";
+ }
+ my $htdocs;
+ if ($opac ne "intranet") {
+ $htdocs = C4::Context->config('opachtdocs');
+ } else {
+ $htdocs = C4::Context->config('intrahtdocs');
+ }
+ my $path = C4::Context->preference('intranet_includes') || 'includes';
+# warn "PATH : $path";
+
+ my ($theme, $lang) = themelanguage($htdocs, $tmplbase, $opac, $query);
+ my $opacstylesheet = C4::Context->preference('opacstylesheet');
+
+my $template = HTML::Template->new(filename => "$htdocs/$theme/$lang/$tmplbase", case_sensitive=>1, utf8=>1,
+ die_on_bad_params => 0,
+ global_vars => 1, cache=>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'),
+ theme => $theme,
+ opacstylesheet => $opacstylesheet,
+ opaccolorstylesheet => C4::Context->preference('opaccolorstylesheet'),
+ opacsmallimage => C4::Context->preference('opacsmallimage'),
+ lang => $lang);
+
+
+ return $template;
+}
+
+#---------------------------------------------------------------------------------------------------------
+# FIXME - POD
+sub themelanguage {
+ 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 {
+ @languages = split " ", C4::Context->preference("opaclanguages");
+ @themes = split " ", C4::Context->preference("template");
+ }
+ }else{
+ $lang=$query->cookie('KohaOpacLanguage');
+
+ if ($lang){
+
+ push @languages,$lang;
+ @themes = split " ", C4::Context->preference("opacthemes");
+ }
+ else {
+ @languages = split " ", C4::Context->preference("opaclanguages");
+ @themes = split " ", C4::Context->preference("opacthemes");
+ }
+}
+
+
+# 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) {
+ $la =~ s/([-_])/ $1 eq '-'? '_': '-' /eg if $pass == 2;
+ if (-e "$htdocs/$th/$la/$tmpl") {
+ $theme = $th;
+ $lang = $la;
+ last THEME;
+ }
+ last unless $la =~ /[-_]/;
+ }
+ }
+ }
+ if ($theme and $lang) {
+ return ($theme, $lang);
+ } else {
+ return ('default', 'en');
+ }
+}
+
+
+sub setlanguagecookie {
+ my ($query,$language,$uri)=@_;
+ my $cookie=$query->cookie(-name => 'KohaOpacLanguage',
+ -value => $language,
+ -expires => '');
+ print $query->redirect(-uri=>$uri,
+ -cookie=>$cookie);
+}
+
+=item pagination_bar
+
+ pagination_bar($base_url, $nb_pages, $current_page, $startfrom_name)
+
+Build an HTML pagination bar based on the number of page to display, the
+current page and the url to give to each page link.
+
+C<$base_url> is the URL for each page link. The
+C<$startfrom_name>=page_number is added at the end of the each URL.
+
+C<$nb_pages> is the total number of pages available.
+
+C<$current_page> is the current page number. This page number won't become a
+link.
+
+This function returns HTML, without any language dependency.
+
+=cut
+
+sub pagination_bar {
+ 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.'='
+ ;
+
+ my $pagination_bar = '';
+
+ # current page detection
+ if (not defined $current_page) {
+ $current_page = 1;
+ }
+
+ # navigation bar useful only if more than one page to display !
+ if ($nb_pages > 1) {
+ # link to first page?
+ if ($current_page > 1) {
+ $pagination_bar.=
+ "\n".' '
+ .'<a href="'.$url.'1" rel="start">'
+ .'<<'
+ .'</a>'
+ ;
+ }
+ else {
+ $pagination_bar.=
+ "\n".' <span class="inactive"><<</span>';
+ }
+
+ # link on previous page ?
+ if ($current_page > 1) {
+ my $previous = $current_page - 1;
+
+ $pagination_bar.=
+ "\n".' '
+ .'<a href="'
+ .$url.$previous
+ .'" rel="prev">'
+ .'<'
+ .'</a>'
+ ;
+ }
+ else {
+ $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
+ 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>'
+ ;
+ }
+ else {
+ $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) {
+ my $next = $current_page + 1;
+
+ $pagination_bar.=
+ "\n".' <a href="'.$url.$next.'" rel="next">'
+ .'>'
+ .'</a>'
+ ;
+ }
+ else {
+ $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>'
+ ;
+ }
+ else {
+ $pagination_bar.=
+ "\n".' <span class="inactive">>></span>';
+ }
+ }
+
+ return $pagination_bar;
+}
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Print.pm
===================================================================
RCS file: Print.pm
diff -N Print.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Print.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,225 @@
+package C4::Print; #assumes C4/Print.pm
+
+
+# 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
+
+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;
+
+=head1 NAME
+
+C4::Print - Koha module dealing with printing
+
+=head1 SYNOPSIS
+
+ use C4::Print;
+
+=head1 DESCRIPTION
+
+The functions in this module handle sending text to a printer.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&remoteprint &printreserve &printslip);
+
+=item remoteprint
+
+ &remoteprint($env, $items, $borrower);
+
+Prints the list of items in C<$items> to a printer.
+
+C<$env> is a reference-to-hash. C<$env-E<gt>{queue}> specifies the
+queue to print to; if it is empty or has the special value C<nulllp>,
+C<&remoteprint> will print to the file F</tmp/kohaiss>.
+
+C<$borrower> is a reference-to-hash giving information about a patron.
+This may be gotten from C<&getpatroninformation>. The patron's name
+will be printed in the output.
+
+C<$items> is a reference-to-list, where each element is a
+reference-to-hash describing a borrowed item. C<$items> may be gotten
+from C<¤tissues>.
+
+=cut
+#'
+# FIXME - It'd be nifty if this could generate pretty PostScript.
+sub remoteprint {
+ my ($env,$items,$borrower)=@_;
+
+ (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.
+ # FIXME - Perhaps "print to file" should be a supported option. Just
+ # 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 {
+ # 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";
+ }
+# print $queue;
+ #open (FILE,">/tmp/$file");
+ 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 "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";
+ # FIXME - Use for ($i = 0; $items->[$i]; $i++)
+ # Or better yet, foreach $item (@{$items})
+ 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 "$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"){
+ #print chr(27).chr(105);
+ }
+ close PRINTER;
+ #system("lpr /tmp/$file");
+}
+
+sub printreserve {
+ 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";
+ }
+ 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]);
+ my $slip = <<"EOF";
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Date: $todaysdate;
+
+ITEM RESERVED:
+$itemdata->{'title'} ($itemdata->{'author'})
+barcode: $itemdata->{'barcode'}
+
+COLLECT AT: $branchname
+
+BORROWER:
+$bordata->{'surname'}, $bordata->{'firstname'}
+card number: $bordata->{'cardnumber'}
+Phone: $bordata->{'phone'}
+$bordata->{'streetaddress'}
+$bordata->{'suburb'}
+$bordata->{'town'}
+$bordata->{'emailaddress'}
+
+
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+EOF
+ print PRINTER $slip;
+ close PRINTER;
+ return $slip;
+}
+
+=item printslip
+
+ &printslip($env, $borrowernumber)
+
+ 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 @issues;
+ 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]";
+ $i++;
+ }
+ 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]";
+ $i++;
+ }
+ remoteprint($env,\@issues,$borrower);
+}
+
+END { } # module clean-up code here (global destructor)
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=head1 SEE ALSO
+
+C4::Circulation::Circ2(3)
+
+=cut
Index: Record.pm
===================================================================
RCS file: Record.pm
diff -N Record.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Record.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,575 @@
+package C4::Record;
+#
+# Copyright 2006 (C) LibLime
+# Joshua Ferraro <jmf at liblime.com>
+#
+# 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: Record.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+#
+use strict; use warnings; #FIXME: turn off warnings before release
+
+# please specify in which methods a given module is used
+use MARC::Record; # marc2marcxml, marcxml2marc, html2marc, changeEncoding
+use MARC::File::XML; # marc2marcxml, marcxml2marc, html2marcxml, changeEncoding
+#use MARC::Crosswalk::DublinCore; # marc2dcxml
+#use MODS::Record; # marc2modsxml
+use Unicode::Normalize; # _entity_encode
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+ at ISA = qw(Exporter);
+
+# only export API methods
+
+ at EXPORT = qw(
+ &marc2marc
+ &marc2marcxml
+ &marcxml2marc
+ &marc2dcxml
+ &marc2modsxml
+
+ &html2marcxml
+ &html2marc
+ &changeEncoding
+);
+
+=head1 NAME
+
+C4::Record - MARC, MARCXML, DC, MODS, XML, etc. Record Management Functions and API
+
+=head1 SYNOPSIS
+
+New in Koha 3.x. This module handles all record-related management functions.
+
+=head1 API (EXPORTED FUNCTIONS)
+
+=head2 marc2marc - Convert from one flavour of ISO-2709 to another
+
+=over 4
+
+my ($error,$newmarc) = marc2marc($marc,$to_flavour,$from_flavour,$encoding);
+
+Returns an ISO-2709 scalar
+
+=back
+
+=cut
+
+sub marc2marc {
+ my ($marc,$to_flavour,$from_flavour,$encoding) = @_;
+ my $error = "Feature not yet implemented\n";
+ return ($error,$marc);
+}
+
+=head2 marc2marcxml - Convert from ISO-2709 to MARCXML
+
+=over 4
+
+my ($error,$marcxml) = marc2marcxml($marc,$encoding,$flavour);
+
+Returns a MARCXML scalar
+
+=over 2
+
+C<$marc> - an ISO-2709 scalar or MARC::Record object
+
+C<$encoding> - UTF-8 or MARC-8 [UTF-8]
+
+C<$flavour> - MARC21 or UNIMARC
+
+C<$dont_entity_encode> - a flag that instructs marc2marcxml not to entity encode the xml before returning (optional)
+
+=back
+
+=back
+
+=cut
+
+sub marc2marcxml {
+ my ($marc,$encoding,$flavour,$dont_entity_encode) = @_;
+ my $error; # the error string
+ my $marcxml; # the final MARCXML scalar
+
+ # test if it's already a MARC::Record object, if not, make it one
+ my $marc_record_obj;
+ if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
+ $marc_record_obj = $marc;
+ } else { # it's not a MARC::Record object, make it one
+ eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
+
+ # conversion to MARC::Record object failed, populate $error
+ if ($@) { $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR };
+ }
+ # only proceed if no errors so far
+ unless ($error) {
+
+ # check the record for warnings
+ my @warnings = $marc_record_obj->warnings();
+ if (@warnings) {
+ warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
+ foreach my $warn (@warnings) { warn "\t".$warn };
+ }
+ unless($encoding) {$encoding = "UTF-8"}; # set default encoding
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set default MARC flavour
+
+ # attempt to convert the record to MARCXML
+ eval { $marcxml = $marc_record_obj->as_xml_record($flavour) }; #handle exceptions
+
+ # record creation failed, populate $error
+ if ($@) {
+ $error .= "Creation of MARCXML failed:".$MARC::File::ERROR;
+ $error .= "Additional information:\n";
+ my @warnings = $@->warnings();
+ foreach my $warn (@warnings) { $error.=$warn."\n" };
+
+ # record creation was successful
+ } else {
+
+ # check the record for warning flags again (warnings() will be cleared already if there was an error, see above block
+ @warnings = $marc_record_obj->warnings();
+ if (@warnings) {
+ warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
+ foreach my $warn (@warnings) { warn "\t".$warn };
+ }
+ }
+
+ # only proceed if no errors so far
+ unless ($error) {
+
+ # entity encode the XML unless instructed not to
+ unless ($dont_entity_encode) {
+ my ($marcxml_entity_encoded) = _entity_encode($marcxml);
+ $marcxml = $marcxml_entity_encoded;
+ }
+ }
+ }
+ # return result to calling program
+ return ($error,$marcxml);
+}
+
+=head2 marcxml2marc - Convert from MARCXML to ISO-2709
+
+=over 4
+
+my ($error,$marc) = marcxml2marc($marcxml,$encoding,$flavour);
+
+Returns an ISO-2709 scalar
+
+=over 2
+
+C<$marcxml> - a MARCXML record
+
+C<$encoding> - UTF-8 or MARC-8 [UTF-8]
+
+C<$flavour> - MARC21 or UNIMARC
+
+=back
+
+=back
+
+=cut
+
+sub marcxml2marc {
+ my ($marcxml,$encoding,$flavour) = @_;
+ my $error; # the error string
+ my $marc; # the final ISO-2709 scalar
+ unless($encoding) {$encoding = "UTF-8"}; # set the default encoding
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set the default MARC flavour
+
+ # attempt to do the conversion
+ eval { $marc = MARC::Record->new_from_xml($marcxml,$encoding,$flavour) }; # handle exceptions
+
+ # record creation failed, populate $error
+ if ($@) {$error .="\nCreation of MARCXML Record failed: ".$@;
+ $error.=$MARC::File::ERROR if ($MARC::File::ERROR);
+ };
+ # return result to calling program
+ return ($error,$marc);
+}
+
+=head2 marc2dcxml - Convert from ISO-2709 to Dublin Core
+
+=over 4
+
+my ($error,$dcxml) = marc2dcxml($marc,$qualified);
+
+Returns a DublinCore::Record object, will eventually return a Dublin Core scalar
+
+FIXME: should return actual XML, not just an object
+
+=over 2
+
+C<$marc> - an ISO-2709 scalar or MARC::Record object
+
+C<$qualified> - specify whether qualified Dublin Core should be used in the input or output [0]
+
+=back
+
+=back
+
+=cut
+
+sub marc2dcxml {
+ my ($marc,$qualified) = @_;
+ my $error;
+ # test if it's already a MARC::Record object, if not, make it one
+ my $marc_record_obj;
+ if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
+ $marc_record_obj = $marc;
+ } else { # it's not a MARC::Record object, make it one
+ eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
+
+ # conversion to MARC::Record object failed, populate $error
+ if ($@) {
+ $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR;
+ }
+ }
+ my $crosswalk = MARC::Crosswalk::DublinCore->new;
+ if ($qualified) {
+ $crosswalk = MARC::Crosswalk::DublinCore->new( qualified => 1 );
+ }
+ my $dcxml = $crosswalk->as_dublincore($marc_record_obj);
+ return ($error,$dcxml);
+}
+=head2 marc2modsxml - Convert from ISO-2709 to MODS
+
+=over 4
+
+my ($error,$modsxml) = marc2modsxml($marc);
+
+Returns a MODS scalar
+
+=back
+
+=cut
+
+sub marc2modsxml {
+ use XML::XSLT;
+ #use XML::LibXSLT;
+ my ($marc) = @_;
+ my $error;
+ my $marcxml;
+
+ # open some files for testing
+ open MARCBIG21MARC21SLIM,"/home/koha/head/koha/C4/MARC21slim2MODS3-1.xsl" or die $!;
+ my $marcbig2marc21_slim; # = scalar (MARC21MARC8);
+ foreach my $line (<MARCBIG21MARC21SLIM>) {
+ $marcbig2marc21_slim .= $line;
+ }
+
+ # set some defailts
+ my $to_encoding = "UTF-8";
+ my $flavour = "MARC21";
+
+ # first convert our ISO-2709 to MARCXML
+ ($error,$marcxml) = marc2marcxml($marc,$to_encoding,$flavour);
+ my $xslt_obj = XML::XSLT->new ($marcbig2marc21_slim, warnings => 1);
+ $xslt_obj->transform ($marcxml);
+ my $xslt_string = $xslt_obj->toString;
+ $xslt_obj->dispose();
+ warn $xslt_string;
+ return ($error,$xslt_string);
+}
+=head2 html2marcxml
+
+=over 4
+
+my ($error,$marcxml) = html2marcxml($tags,$subfields,$values,$indicator,$ind_tag);
+
+Returns a MARCXML scalar
+
+this is used in addbiblio.pl and additem.pl to build the MARCXML record from
+the form submission.
+
+FIXME: this could use some better code documentation
+
+=back
+
+=cut
+
+sub html2marcxml {
+ my ($tags,$subfields,$values,$indicator,$ind_tag) = @_;
+ my $error;
+ # add the header info
+ my $marcxml= MARC::File::XML::header(C4::Context->preference('TemplateEncoding'),C4::Context->preference('marcflavour'));
+
+ # some flags used to figure out where in the record we are
+ my $prevvalue;
+ my $prevtag=-1;
+ my $first=1;
+ my $j = -1;
+
+ # handle characters that would cause the parser to choke FIXME: is there a more elegant solution?
+ 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 ((@$tags[$i] ne $prevtag)){
+ $j++ unless (@$tags[$i] eq "");
+ #warn "IND:".substr(@$indicator[$j],0,1).substr(@$indicator[$j],1,1)." ".@$tags[$i];
+ if (!$first){
+ $marcxml.="</datafield>\n";
+ if ((@$tags[$i] > 10) && (@$values[$i] ne "")){
+ my $ind1 = substr(@$indicator[$j],0,1);
+ my $ind2 = substr(@$indicator[$j],1,1);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ $first=0;
+ } else {
+ $first=1;
+ }
+ } else {
+ if (@$values[$i] ne "") {
+ # handle the leader
+ if (@$tags[$i] eq "000") {
+ $marcxml.="<leader>@$values[$i]</leader>\n";
+ $first=1;
+ # rest of the fixed fields
+ } elsif (@$tags[$i] < 010) { #FIXME: <10 was the way it was, there might even be a better way
+ $marcxml.="<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);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $marcxml.="<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);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $first=0;
+ }
+ $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ }
+ }
+ $prevtag = @$tags[$i];
+ }
+ $marcxml.= MARC::File::XML::footer();
+ #warn $marcxml;
+ return ($error,$marcxml);
+}
+
+=head2 html2marc
+
+=over 4
+
+Probably best to avoid using this ... it has some rather striking problems:
+
+=over 2
+
+* saves blank subfields
+
+* subfield order is hardcoded to always start with 'a' for repeatable tags (because it is hardcoded in the addfield routine).
+
+* only possible to specify one set of indicators for each set of tags (ie, one for all the 650s). (because they were stored in a hash with the tag as the key).
+
+* the underlying routines didn't support subfield reordering or subfield repeatability.
+
+=back
+
+I've left it in here because it could be useful if someone took the time to fix it. -- kados
+
+=back
+
+=cut
+
+sub html2marc {
+ 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++) {
+ # 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') && ($prevvalue ne "")) {
+ $record->add_fields((sprintf "%03s",$prevtag),$prevvalue);
+ } elsif ($prevvalue ne ""){
+ $record->leader($prevvalue);
+ }
+ }
+ } else {
+ if (($field) && ($field ne "")) {
+ $record->add_fields($field);
+ }
+ }
+ $indicators{@$rtags[$i]}.=' ';
+ # skip blank tags, I hope this works
+ if (@$rtags[$i] eq ''){
+ $prevtag = @$rtags[$i];
+ undef $field;
+ next;
+ }
+ if (@$rtags[$i] <10) {
+ $prevvalue= @$rvalues[$i];
+ undef $field;
+ } else {
+ undef $prevvalue;
+ if (@$rvalues[$i] eq "") {
+ undef $field;
+ } else {
+ $field = MARC::Field->new( (sprintf "%03s",@$rtags[$i]), substr($indicators{@$rtags[$i]},0,1),substr($indicators{@$rtags[$i]},1,1), @$rsubfields[$i] => @$rvalues[$i]);
+ }
+# warn "1=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
+ }
+ $prevtag = @$rtags[$i];
+ } else {
+ if (@$rtags[$i] <10) {
+ $prevvalue=@$rvalues[$i];
+ } else {
+ if (length(@$rvalues[$i])>0) {
+ $field->add_subfields(@$rsubfields[$i] => @$rvalues[$i]);
+# warn "2=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
+ }
+ }
+ $prevtag= @$rtags[$i];
+ }
+ }
+ #}
+ # the last has not been included inside the loop... do it now !
+ #use Data::Dumper;
+ #warn Dumper($field->{_subfields});
+ $record->add_fields($field) if (($field) && $field ne "");
+ #warn "HTML2MARC=".$record->as_formatted;
+ return $record;
+}
+
+=head2 changeEncoding - Change the encoding of a record
+
+=over 4
+
+my ($error, $newrecord) = changeEncoding($record,$format,$flavour,$to_encoding,$from_encoding);
+
+Changes the encoding of a record
+
+=over 2
+
+C<$record> - the record itself can be in ISO-2709, a MARC::Record object, or MARCXML for now (required)
+
+C<$format> - MARC or MARCXML (required)
+
+C<$flavour> - MARC21 or UNIMARC, if MARC21, it will change the leader (optional) [defaults to Koha system preference]
+
+C<$to_encoding> - the encoding you want the record to end up in (optional) [UTF-8]
+
+C<$from_encoding> - the encoding the record is currently in (optional, it will probably be able to tell unless there's a problem with the record)
+
+=back
+
+FIXME: the from_encoding doesn't work yet
+
+FIXME: better handling for UNIMARC, it should allow management of 100 field
+
+FIXME: shouldn't have to convert to and from xml/marc just to change encoding someone needs to re-write MARC::Record's 'encoding' method to actually alter the encoding rather than just changing the leader
+
+=back
+
+=cut
+
+sub changeEncoding {
+ my ($record,$format,$flavour,$to_encoding,$from_encoding) = @_;
+ my $newrecord;
+ my $error;
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")};
+ unless($to_encoding) {$to_encoding = "UTF-8"};
+
+ # ISO-2709 Record (MARC21 or UNIMARC)
+ if (lc($format) =~ /^marc$/o) {
+ # if we're converting encoding of an ISO2709 file, we need to roundtrip through XML
+ # because MARC::Record doesn't directly provide us with an encoding method
+ # It's definitely less than idea and should be fixed eventually - kados
+ my $marcxml; # temporary storage of MARCXML scalar
+ ($error,$marcxml) = marc2marcxml($record,$to_encoding,$flavour);
+ unless ($error) {
+ ($error,$newrecord) = marcxml2marc($marcxml,$to_encoding,$flavour);
+ }
+
+ # MARCXML Record
+ } elsif (lc($format) =~ /^marcxml$/o) { # MARCXML Record
+ my $marc;
+ ($error,$marc) = marcxml2marc($record,$to_encoding,$flavour);
+ unless ($error) {
+ ($error,$newrecord) = marc2marcxml($record,$to_encoding,$flavour);
+ }
+ } else {
+ $error.="Unsupported record format:".$format;
+ }
+ return ($error,$newrecord);
+}
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _entity_encode - Entity-encode an array of strings
+
+=over 4
+
+my ($entity_encoded_string) = _entity_encode($string);
+
+or
+
+my (@entity_encoded_strings) = _entity_encode(@strings);
+
+Entity-encode an array of strings
+
+=back
+
+=cut
+
+sub _entity_encode {
+ my @strings = @_;
+ my @strings_entity_encoded;
+ foreach my $string (@strings) {
+ my $nfc_string = NFC($string);
+ $nfc_string =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
+ push @strings_entity_encoded, $nfc_string;
+ }
+ return @strings_entity_encoded;
+}
+
+END { } # module clean-up code here (global destructor)
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Joshua Ferraro <jmf at liblime.com>
+
+=head1 MODIFICATIONS
+
+# $Id: Record.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+=cut
Index: Reserves2.pm
===================================================================
RCS file: Reserves2.pm
diff -N Reserves2.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Reserves2.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,759 @@
+# -*- tab-width: 8 -*-
+# NOTE: This file uses standard 8-character tabs
+
+package C4::Reserves2;
+
+# $Id: Reserves2.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is hard coded with koha-reserves table to be used only by the OPAC -TG.
+#
+# 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
+
+use strict;
+require Exporter;
+
+use C4::Context;
+use C4::Biblio;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Reserves2 - FIXME
+
+=head1 SYNOPSIS
+
+ use C4::Reserves2;
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+# FIXME Take out CalcReserveFee after it can be removed from opac-reserves.pl
+ at EXPORT = qw(&FindReserves
+ &FindAllReserves
+ &CheckReserves
+ &CheckWaiting
+ &CancelReserve
+ &CalcReserveFee
+ &FillReserve
+ &ReserveWaiting
+ &CreateReserve
+ &UpdateReserves
+ &UpdateReserve
+ &getreservetitle
+ &Findgroupreserve
+ &findActiveReserve
+
+ );
+
+# make all your functions, whether exported or not;
+
+=item FindReserves
+
+ ($count, $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
+patron whose books to look up.
+
+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.
+
+C<&FindReserves> returns a two-element array:
+
+C<$count> is the number of elements in C<$results>.
+
+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.
+
+=cut
+#'
+sub FindReserves {
+ my ($bib, $bor) = @_;
+ my @params;
+
+ my $dbh = C4::Context->dbh;
+ # 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)";
+
+ push @params, $bor;
+ }
+ $query.=" order by reserves.timestamp";
+ my $sth = $dbh->prepare($query);
+ $sth->execute(@params);
+
+ my $i = 0;
+ 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;
+ $i++;
+ }
+ $sth->finish;
+
+ return($i,\@results);
+}
+
+=item FindAllReserves
+
+ ($count, $results) = &FindAllReserves($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
+patron whose books to look up.
+
+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.
+
+C<&FindAllReserves> returns a two-element array:
+
+C<$count> is the number of elements in C<$results>.
+
+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.
+
+=cut
+#'
+sub FindAllReserves {
+ my ($bib, $bor) = @_;
+ my @params;
+
+my $dbh;
+
+ $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 $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;
+
+ return($i,\@results);
+}
+
+=item CheckReserves
+
+ ($status, $reserve) = &CheckReserves($itemnumber, $barcode);
+
+Find a book in the reserves.
+
+C<$itemnumber> is the book's item number. C<$barcode> is its barcode.
+Either one, but not both, may be false. If both are specified,
+C<&CheckReserves> uses C<$itemnumber>.
+
+$itemnubmer can be false, in which case uses the barcode. (Never uses
+both. $itemnumber gets priority).
+
+As I understand it, C<&CheckReserves> looks for the given item in the
+reserves. If it is found, that's a match, and C<$status> is set to
+C<Waiting>.
+
+Otherwise, it finds the most important item in the reserves with the
+same biblio number as this book (I'm not clear on this) and returns it
+with C<$status> set to C<Reserved>.
+
+C<&CheckReserves> returns a two-element list:
+
+C<$status> is either C<Waiting>, C<Reserved> (see above), or 0.
+
+C<$reserve> is the reserve item that matched. It is a
+reference-to-hash whose keys are mostly the fields of the reserves
+table in the Koha database.
+
+=cut
+#'
+sub CheckReserves {
+ my ($item, $barcode) = @_;
+# warn "In CheckReserves: itemnumber = $item";
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ($item) {
+
+ } else {
+ my $qbc=$dbh->quote($barcode);
+ # Look up the item by barcode
+ $sth=$dbh->prepare("SELECT items.itemnumber
+ FROM items
+ WHERE barcode=$qbc");
+ $sth->execute;
+ ($item) = $sth->fetchrow;
+ $sth->finish;
+ }
+
+
+# if item is not for loan it cannot be reserved either.....
+# return (0, 0) if ($notforloan);
+# get the reserves...
+ # Find this item in the reserves
+ my ($count, @reserves) = Findgroupreserve($item);
+ # $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.)
+ # $highest is the most important item we've seen so far.
+ my $priority = 10000000;
+ my $highest;
+ if ($count) {
+ foreach my $res (@reserves) {
+ if ($res->{found} eq "W"){
+ 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) {
+ $priority = $res->{'priority'};
+ $highest = $res;
+ }
+ }
+ }
+ }
+
+ # If we get this far, then no exact match was found. Print the
+ # most important item on the list. I think this tells us who's
+ # next in line to get this book.
+ if ($highest) { # FIXME - $highest might be undefined
+ $highest->{'itemnumber'} = $item;
+ return ("Reserved", $highest);
+ } else {
+ return (0, 0);
+ }
+}
+
+=item CancelReserve
+
+ &CancelReserve($reserveid);
+
+Cancels a reserve.
+
+Use reserveid to cancel the reservation.
+
+C<$reserveid> is the reserve ID to cancel.
+
+=cut
+#'
+sub CancelReserve {
+ my ($biblio, $item, $borr) = @_;
+
+my $dbh;
+
+ $dbh = C4::Context->dbh;
+
+ #warn "In CancelReserve";
+ if (($item and $borr) and (not $biblio)) {
+ # removing a waiting reserve record....
+ # update the database...
+ my $sth = $dbh->prepare("update reserves set cancellationdate = now(),
+ found = Null,
+ priority = 0
+ where itemnumber = ?
+ and borrowernumber = ?");
+ $sth->execute($item,$borr);
+ $sth->finish;
+ }
+ 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
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND cancellationdate is NULL
+ AND (found <> 1 )");
+ $sth->execute($biblio,$borr);
+ ($priority) = $sth->fetchrow_array;
+ $sth->finish;
+
+ # 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->finish;
+ # now fix the priority on the others....
+ fixpriority($priority, $biblio);
+ }
+}
+=item FillReserve
+
+ &FillReserve($reserveid, $itemnumber);
+
+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.
+
+=cut
+#'
+sub FillReserve {
+ my ($res) = @_;
+my $dbh;
+ $dbh = C4::Context->dbh;
+ # fill in a reserve record....
+ # FIXME - Remove some of the redundancy here
+ my $biblio = $res->{'biblionumber'}; my $qbiblio =$biblio;
+ my $borr = $res->{'borrowernumber'};
+ my $resdate = $res->{'reservedate'};
+
+ # get the priority on this record....
+ my $priority;
+ {
+ my $query = "SELECT priority FROM reserves
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?";
+ 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,
+ priority = 0
+ WHERE biblionumber = ?
+ AND reservedate = ?
+ AND borrowernumber = ?";
+ my $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);
+ }
+}
+
+# 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;
+
+ my ($count, $reserves) = FindReserves($biblio);
+ foreach my $rec (@$reserves) {
+ if ($rec->{'priority'} > $priority) {
+ my $sth = $dbh->prepare("UPDATE reserves SET priority = ?
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND reservedate = ?");
+ $sth->execute($rec->{'priority'},$rec->{'biblionumber'},$rec->{'borrowernumber'},$rec->{'reservedate'});
+ $sth->finish;
+ }
+ }
+}
+
+# XXX - POD
+sub ReserveWaiting {
+ my ($item, $borr) = @_;
+
+my $dbh;
+
+ $dbh = C4::Context->dbh;
+
+# get priority and biblionumber....
+ my $sth = $dbh->prepare("SELECT reserves.priority as priority,
+ reserves.biblionumber as biblionumber,
+ reserves.branchcode as branchcode,
+ reserves.timestamp as timestamp
+ FROM reserves
+ WHERE reserves.itemnumber = ?
+ AND reserves.borrowernumber = ?
+ AND reserves.cancellationdate is NULL
+ AND (reserves.found <> '1' or reserves.found is NULL)");
+ $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'
+ WHERE borrowernumber = ?
+ AND itemnumber = ?
+ AND timestamp = ?");
+ $sth->execute($borr,$item,$timestamp);
+ $sth->finish;
+# now fix up the remaining priorities....
+ fixpriority($data->{'priority'}, $biblio);
+ my $branchcode = $data->{'branchcode'};
+ return $branchcode;
+}
+
+# XXX - POD
+sub CheckWaiting {
+ my ($borr)=@_;
+
+my $dbh;
+ $dbh = C4::Context->dbh;
+ my @itemswaiting;
+ my $sth = $dbh->prepare("SELECT * FROM reserves
+ WHERE borrowernumber = ?
+ AND reserves.found = 'W'
+ AND cancellationdate is NULL");
+ $sth->execute($borr);
+ while (my $data=$sth->fetchrow_hashref) {
+ push(@itemswaiting,$data);
+ }
+ $sth->finish;
+ return (scalar(@itemswaiting),\@itemswaiting);
+}
+
+=item Findgroupreserve
+
+ ($count, @results) = &Findgroupreserve($biblioitemnumber, $biblionumber);
+
+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<@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 *
+ FROM reserves
+ WHERE (itemnumber = ?) AND
+ (cancellationdate IS NULL) AND
+ (found <> 1)
+ ORDER BY timestamp");
+ $sth->execute($itemnumber);
+ my @results;
+ while (my $data = $sth->fetchrow_hashref) {
+ push(@results,$data);
+ }
+ $sth->finish;
+ return(scalar(@results), at 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) = @_;
+
+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) {
+
+ my $nextacctno = &getnextacctno($env,$borrnum,$dbh);
+ my $usth = $dbh->prepare("insert into accountlines
+ (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
+ values
+ (?,?,now(),?,?,'Res',?)");
+ $usth->execute($borrnum,$nextacctno,$fee,'Reserve Charge -'. $title,$fee);
+ $usth->finish;
+ }
+ return 1;
+}
+
+# FIXME - A functionally identical version of this function appears in
+# C4::Reserves. Pick one and stick with it.
+# XXX - Internal use only
+# 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 $const = lc substr($constraint,0,1);
+ my $sth = $dbh->prepare("SELECT * FROM borrowers,categories
+ WHERE (borrowernumber = ?)
+ AND (borrowers.categorycode = categories.categorycode)");
+ $sth->execute($borrnum);
+ my $data = $sth->fetchrow_hashref;
+ $sth->finish();
+ my $fee = $data->{'reservefee'};
+
+ if ($fee > 0) {
+ # check for items on issue
+
+
+ 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
+ WHERE itemnumber = ?
+ 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 = ?");
+ $rsth->execute($biblionumber);
+ if (my $rdata = $rsth->fetchrow_hashref) {
+ } else {
+ $fee = 0;
+ }
+ }
+ }
+# print "fee $fee";
+
+ return $fee;
+}
+
+# XXX - Internal use
+sub getnextacctno {
+ my ($env,$bornumber,$dbh)=@_;
+ my $nextaccntno = 1;
+ my $sth = $dbh->prepare("select * from accountlines
+ where (borrowernumber = ?)
+ order by accountno desc");
+ $sth->execute($bornumber);
+ if (my $accdata=$sth->fetchrow_hashref){
+ $nextaccntno = $accdata->{'accountno'} + 1;
+ }
+ $sth->finish;
+ return($nextaccntno);
+}
+
+# XXX - POD
+sub UpdateReserves {
+ #subroutine to update a reserve
+ my ($rank,$biblio,$borrower,$branch,$cataloger)=@_;
+ 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=?
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND cancellationdate is NULL
+ AND (found <> 1 )");
+ $sth->execute($cataloger,$biblio, $borrower);
+ $sth->finish;
+ } else {
+ my $sth=$dbh->prepare("UPDATE reserves SET priority = ? ,branchcode = ?, found = 0
+ WHERE biblionumber = ?
+ AND borrowernumber = ?
+ AND cancellationdate is NULL
+ AND (found <> 1)");
+ $sth->execute($rank, $branch, $biblio, $borrower);
+ $sth->finish;
+ }
+}
+
+# XXX - POD
+sub UpdateReserve {
+ #subroutine to update a reserve
+ my ($reserveid, $timestamp) = @_;
+
+my $dbh;
+ $dbh = C4::Context->dbh;
+
+
+ my $sth=$dbh->prepare("UPDATE reserves
+ SET timestamp = $timestamp,
+ reservedate = DATE_FORMAT($timestamp, '%Y-%m-%d')
+ WHERE (reserveid = $reserveid)");
+ $sth->execute();
+ $sth->finish;
+}
+
+# XXX - PODXX Is this function Used?
+sub getreservetitle {
+ my ($biblio,$bor,$date,$timestamp)=@_;
+my $dbh = C4::Context->dbh;
+
+
+ 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);
+}
+
+sub findActiveReserve {
+ my ($borrowernumber, $biblionumber, $from, $days) = @_;
+my $dbh = C4::Context->dbh;
+
+ my $sth = $dbh->prepare("SELECT *
+ FROM reserves
+ WHERE
+ borrowernumber = ?
+ 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);
+}
+
+1;
+__END__
\ No newline at end of file
Index: Review.pm
===================================================================
RCS file: Review.pm
diff -N Review.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Review.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,196 @@
+package C4::Review;
+
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Review - Perl Module containing routines for dealing with reviews of items
+
+=head1 SYNOPSIS
+
+ use C4::Review;
+
+
+ my $review=getreview($biblionumber,$borrowernumber);
+ savereview($biblionumber,$borrowernumber,$review);
+ updatereview($biblionumber,$borrowernumber,$review);
+ my $count=numberofreviews($biblionumber);
+ my $reviews=getreviews($biblionumber);
+ my $reviews=getallreviews($status);
+
+=head1 DESCRIPTION
+
+Review.pm provides many routines for manipulating reviews.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(getreview savereview updatereview numberofreviews
+ getreviews getallreviews approvereview deletereview);
+
+use vars qw();
+
+my $DEBUG = 0;
+
+=head2 getreview
+
+ $review = getreview($biblionumber,$borrowernumber);
+
+Takes a borrowernumber and a biblionumber and returns the review of that biblio
+
+
+=cut
+
+sub getreview {
+ my ( $biblionumber, $borrowernumber ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =
+ "SELECT * FROM reviews WHERE biblionumber=? and borrowernumber=?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblionumber, $borrowernumber );
+ my $review = $sth->fetchrow_hashref();
+ $sth->finish();
+ return $review;
+}
+
+sub savereview {
+ my ( $biblionumber, $borrowernumber, $review ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "INSERT INTO reviews (borrowernumber,biblionumber,
+ review,approved,datereviewed) VALUES
+ (?,?,?,?,now())";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $borrowernumber, $biblionumber, $review, 0 );
+ $sth->finish();
+}
+
+sub updatereview {
+ my ( $biblionumber, $borrowernumber, $review ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = "UPDATE reviews SET review=?,datereviewed=now(),approved=?
+ WHERE borrowernumber=? and biblionumber=?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $review, 0, $borrowernumber, $biblionumber );
+ $sth->finish();
+
+}
+
+sub numberofreviews {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =
+ "SELECT count(*) FROM reviews WHERE biblionumber=? and approved=?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $biblionumber, 1 );
+ my $count = $sth->fetchrow_hashref;
+
+ $sth->finish();
+ return ( $count->{'count(*)'} );
+}
+
+sub getreviews {
+ my ( $biblionumber, $approved ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =
+"SELECT * FROM reviews WHERE biblionumber=? and approved=? order by datereviewed desc";
+ my $sth = $dbh->prepare($query) || warn $dbh->err_str;
+ $sth->execute( $biblionumber, $approved );
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref() ) {
+ push @results, $data;
+ }
+ $sth->finish();
+ return ( \@results );
+}
+
+sub getallreviews {
+ my ($status) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =
+ "SELECT * FROM reviews WHERE approved=? order by datereviewed desc";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($status);
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref() ) {
+ push @results, $data;
+ }
+ $sth->finish();
+ return ( \@results );
+}
+
+=head2 approvereview
+
+ approvereview($reviewid);
+
+Takes a reviewid and marks that review approved
+
+
+=cut
+
+sub approvereview {
+ my ($reviewid) = @_;
+ my $dbh = C4::Context->dbh();
+ my $query = "UPDATE reviews
+ SET approved=?
+ WHERE reviewid=?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( 1, $reviewid );
+ $sth->finish();
+}
+
+=head2 deletereview
+
+ deletereview($reviewid);
+
+Takes a reviewid and deletes it
+
+
+=cut
+
+sub deletereview {
+ my ($reviewid) = @_;
+ my $dbh = C4::Context->dbh();
+ my $query = "DELETE FROM reviews
+ WHERE reviewid=?";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($reviewid);
+ $sth->finish();
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Team
+
+=cut
Index: SMS.pm
===================================================================
RCS file: SMS.pm
diff -N SMS.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ SMS.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,149 @@
+package C4::SMS;
+#Written by tgarip at neu.edu.tr for SMS message sending and other SMS related services
+
+use strict;
+require Exporter;
+use LWP::UserAgent;
+use C4::Context;
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = 0.01;
+my $user=C4::Context->config('smsuser');
+my $pwd=C4::Context->config('smspass');
+my $uri ="https://spgw.kktcell.com/smshttpproxy/SmsHttpProxyServlet";
+
+
+
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(
+&get_sms_auth
+&send_sms
+&read_sms
+&error_codes
+&parse_phone
+&parse_message
+&write_sms
+&mod_sms
+&kill_sms
+);
+
+sub get_sms_auth {
+ my $ua = LWP::UserAgent->new;
+my $commands;
+ my $res=$ua->post($uri,[cmd=>'REGISTER',pUser=>$user,pPwd=>$pwd]);
+ if ($res->is_success){
+ $commands=parse_content($res->content);
+ }
+return($commands,$ua);
+}
+
+sub send_sms{
+my $ua=shift;
+my $phone=shift;
+my $message=shift;
+my $session=shift;
+ my $res=$ua->post($uri,[cmd=>'SENDSMS',pUser=>$user,pPwd=>$pwd,pSessionId=>$session,pService_Code=>4130,pMsisdn=>$phone,
+ pContent=>$message]);
+return parse_content($res->content);
+}
+sub read_sms{
+my $ua=shift;
+my $session=shift;
+ my $res=$ua->post($uri,[cmd=>'GETSMS',pUser=>$user,pPwd=>$pwd,pSessionId=>$session,pService_Code=>4130]);
+return parse_content($res->content);
+}
+sub parse_content{
+my $content=shift;
+my %commands;
+my @attributes=split /&/,$content;
+ foreach my $params(@attributes){
+ my (@param)=split /=/,$params;
+ $commands{$param[0]}=$param[1];
+ }
+return(\%commands);
+}
+
+sub error_codes{
+my $error=shift;
+if ($error==-1){
+return "Closed session - Retry ";
+}elsif($error==-2){
+return "Invalid session - Retry ";
+}elsif($error==-3){
+return "Invalid password" ;
+}elsif($error==-103){
+return "Invalid user";
+}elsif($error==-422){
+return "Invalid Parameter";
+}elsif($error==-426){
+return "User doesn’t have permission to send message";
+}elsif($error==-700){
+return "No permission";
+}elsif($error==-801){
+return " Msdisn count differs-warn administartor";
+}elsif($error==-803){
+return "Content count differs from XSER count";
+}elsif($error==-1101){
+return " Insufficient Credit Do not retry" ;
+}elsif($error==-1104){
+return "Invalid Phone number";
+}elsif($error==-10001){
+return " Internal system error- Tell Turkcell/Telsim";
+}elsif($error==-9005){
+return " No messages to read";
+}elsif ($error){
+return "Unknow error no $error occured - tell Turkcell/Telsim";
+}
+}
+
+sub parse_phone{
+## checks acceptable phone numbers
+## Fix to accept Telsim when available (542 numbers)
+my $phone=shift;
+$phone=~s/^0//g;
+$phone=~s/ //g;
+my $length=length($phone);
+if ($length==10 || $length==12){
+my $code=substr($phone,0,3) if $length==10;
+ $code=substr($phone,0,5) if $length==12;
+ if ($code=~/533/){
+ return $phone;
+ }else{
+ return 0;
+ }
+}else{
+return 0;
+}
+}
+
+sub parse_message{
+my $message=shift;
+$message=~s/ / /g;
+my @parsed=split / /,$message;
+return (@parsed);
+}
+
+sub write_sms{
+my ($userid,$message,$phone)=@_;
+my $dbh=C4::Context->dbh;
+my $sth=$dbh->prepare("INSERT into sms_messages(userid,message,user_phone,date_received) values(?,?,?,now())");
+$sth->execute($userid,$message,$phone);
+$sth->finish;
+return $dbh->{'mysql_insertid'};
+}
+
+sub mod_sms{
+my ($smsid,$message)=@_;
+my $dbh=C4::Context->dbh;
+my $sth=$dbh->prepare("UPDATE sms_messages set reply=? ,date_replied=now() where smsid=?");
+$sth->execute($message,$smsid);
+$sth->finish;
+}
+sub kill_sms{
+#end a session
+my $ua=shift;
+my $session=shift;
+ my $res=$ua->post($uri,[cmd=>'KILLSESSION',pSessionId=>$session]);
+}
+1;
+__END__
\ No newline at end of file
Index: Search.pm
===================================================================
RCS file: Search.pm
diff -N Search.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Search.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,1073 @@
+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
+# 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
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Reserves2;
+use C4::Biblio;
+use ZOOM;
+use Encode;
+use C4::Date;
+use Time::HiRes qw(gettimeofday tv_interval);
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+=head1 NAME
+
+C4::Search - Functions for searching the Koha catalog and other databases
+
+=head1 SYNOPSIS
+
+ use C4::Search;
+
+ my ($count, @results) = catalogsearch4($env, $type, $search, $num, $offset);
+
+=head1 DESCRIPTION
+
+This module provides the searching facilities for the Koha catalog and
+ZEBRA databases.
+
+
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at 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
+
+
+
+
+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 $starttime;
+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 "");
+ }
+ }
+#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
+ }
+}
+
+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:
+$starttime=[gettimeofday];
+$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 $timetaken=sprintf("%.3f",tv_interval($starttime));
+ 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);
+ $oResult->destroy();
+ $oConnection[0]->destroy();
+ $parsed[0]->{timetaken}=$timetaken;
+ return ($numresults,$facets, at parsed) ;
+ }
+ }# if numresults
+
+$oResult->destroy();
+$oConnection[0]->destroy();
+EXITING:
+return ($numresults, at results) ;
+}
+
+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;
+}
+
+return $pqf_query;
+}
+
+
+=item add_bold_fields
+After a search the searched keyword is <b>boldened</b> in the displayed search results if it exists in the title or author
+It is now depreceated
+=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 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);
+}
+
+
+
+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 $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}>
+
+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;
+ }
+ }
+ $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'};
+ }
+
+ $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;
+ }
+
+# 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);
+}
+
+
+
+
+
+=item barcodes
+
+ @barcodes = &barcodes($biblioitemnumber);
+
+Given a biblioitemnumber, looks up the corresponding items.
+
+Returns an array of references-to-hash; the keys are C<barcode> and
+C<itemlost>.
+
+The returned items include very overdue items, but not lost ones.
+
+=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);
+}
+
+
+
+
+
+sub getMARCnotes {
+##Requires a MARCXML as $record
+ my ($dbh, $record, $marcflavour) = @_;
+
+ 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";
+ }
+ my @marcnotes=();
+ my $marcnote;
+ foreach my $field ($mintag..$maxtag) {
+ my %line;
+ my @values=XML_readline_asarray($record,"","",$field,"");
+ foreach my $value (@values){
+ $marcnote = {MARCNOTE => $value,};
+ push @marcnotes, $marcnote;
+ }
+ }
+
+ 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;
+
+ foreach my $field ($mintag..$maxtag) {
+ my @value =XML_readline_asarray($record,"","",$field,"a");
+ foreach my $subject (@value){
+ $marcsubjct = {MARCSUBJCT => $subject,};
+ push @marcsubjcts, $marcsubjct;
+ }
+
+ }
+ my $marcsubjctsarray=\@marcsubjcts;
+ return $marcsubjctsarray;
+} #end getMARCsubjects
+
+
+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";
+ }
+
+ 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;
+ }
+ }
+ }
+
+
+ my $marcurlsarray=\@marcurls;
+ return $marcurlsarray;
+} #end getMARCurls
+
+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";
+ }
+
+ 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;
+ }
+ }
+ }
+
+
+ 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'};
+ }
+
+#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'};
+ }
+ }
+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","totalissue","coverphoto";
+my ($oldbiblio, at itemrecords) = XMLmarc2koha($dbh,$xml,"", at kohafields);
+my $bibliorecord;
+$oldbiblio->{totalissue}=sprintf("%4d",$oldbiblio->{totalissue});
+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;
+ }
+ }
+ }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'};
+ }
+return ($facets_counter,$facets_info);
+}
+
+sub BuildFacets {
+my ($facets_counter, $facets_info,%branches) = @_;
+
+ my @facets_loop; # stores the ref to array of hashes for template
+# BUILD FACETS
+ foreach my $link_value ( sort { $facets_counter->{$b} <=> $facets_counter->{$a} } keys %$facets_counter) {
+ my $expandable;
+ my $number_of_facets;
+ my @this_facets_array;
+ foreach my $one_facet ( sort { $facets_counter->{ $link_value }->{$b} <=> $facets_counter->{ $link_value }->{$a} } keys %{$facets_counter->{$link_value}} ) {
+ $number_of_facets++;
+ if (($number_of_facets < 11) || ($facets_info->{ $link_value }->{ 'expanded'})) {
+
+ # sanitize the link value ), ( will cause errors with CCL
+ my $facet_link_value = $one_facet;
+ $facet_link_value =~ s/(\(|\))/ /g;
+
+ # fix the length that will display in the label
+ my $facet_label_value = $one_facet;
+ $facet_label_value = substr($one_facet,0,20)."..." unless length($facet_label_value)<=20;
+ # well, if it's a branch, label by the name, not the code
+ if ($link_value =~/branch/) {
+ $facet_label_value = $branches{$one_facet};
+ }
+
+ # but we're down with the whole label being in the link's title
+ my $facet_title_value = $one_facet;
+
+ push @this_facets_array ,
+ ( { facet_count => $facets_counter->{ $link_value }->{ $one_facet },
+ facet_label_value => $facet_label_value,
+ facet_title_value => $facet_title_value,
+ facet_link_value => $facet_link_value,
+ type_link_value => $link_value,
+ },
+ );
+ }## if $number_of_facets
+ }##for $one_facet
+ unless ($facets_info->{ $link_value }->{ 'expanded'}) {
+ $expandable=1 if ($number_of_facets > 10);
+ }
+ push @facets_loop,(
+ { type_link_value => $link_value,
+ type_id => $link_value."_id",
+ type_label => $facets_info->{ $link_value }->{ 'label_value' },
+ facets => \@this_facets_array,
+ expandable => $expandable,
+ expand => $link_value,
+ },
+ );
+
+ }
+return \@facets_loop;
+}
+
+
+sub getcoverPhoto {
+## return the address of a cover image if defined otherwise the amazon cover images
+ my $record =shift ;
+
+ 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" if $isbn;
+}
+
+=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.
+
+C<$mending> is the number of items at the Mending branch (being
+mended?).
+
+C<$transit> is the number of items at the Transit branch (in transit
+between branches?).
+
+C<$ocount> is the number of items that haven't arrived yet
+(aqorders.quantity - aqorders.quantityreceived).
+
+=cut
+#'
+
+
+
+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'};
+ }
+# $count+=$ocount;
+
+ return ($count,$lcount,$nacount,$fcount,$scount,$lostcount,$mending,$transit,$ocount);
+}
+
+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;
+}
+
+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-new.pm
===================================================================
RCS file: Serials-new.pm
diff -N Serials-new.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Serials-new.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,1792 @@
+package C4::Serials; #assumes C4/Serials.pm
+
+# 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: Serials-new.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+use C4::Date;
+use Date::Calc qw(:all);
+use C4::Suggestions;
+use C4::Biblio;
+use C4::Search;
+use C4::Letters;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+
+=head1 NAME
+
+C4::Serials - Give functions for serializing.
+
+=head1 SYNOPSIS
+
+ use C4::Serials;
+
+=head1 DESCRIPTION
+
+Give all XYZ functions
+
+=head1 FUNCTIONS
+
+=cut
+ at ISA = qw(Exporter);
+ at 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
+);
+
+=head2 GetSuppliersWithLateIssues
+
+=over 4
+
+%supplierlist = &GetSuppliersWithLateIssues
+
+this function get all suppliers with late issues.
+
+return :
+the supplierlist into a hash. this hash containts id & name of the supplier
+
+=back
+
+=cut
+sub GetSuppliersWithLateIssues {
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT DISTINCT id, name
+ FROM subscription, serial
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND (planneddate < now() OR serial.STATUS = 3 OR serial.STATUS = 4)
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my %supplierlist;
+ while (my ($id,$name) = $sth->fetchrow) {
+ $supplierlist{$id} = $name;
+ }
+ if(C4::Context->preference("RoutingSerials")){
+ $supplierlist{''} = "All Suppliers";
+ }
+ return %supplierlist;
+}
+
+=head2 GetLateIssues
+
+=over 4
+
+ at issuelist = &GetLateIssues($supplierid)
+
+this function select late issues on database
+
+return :
+the issuelist into an table. Each line of this table containts a ref to a hash which it containts
+name,title,planneddate,serialseq,serial.subscriptionid from tables : subscription, serial & biblio
+
+=back
+
+=cut
+sub GetLateIssues {
+ my ($supplierid) = shift;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ($supplierid) {
+ my $query = qq |
+ SELECT name,title,planneddate,serialseq,serial.subscriptionid
+ FROM subscription, serial, biblio
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3)
+ AND subscription.aqbooksellerid=$supplierid
+ AND biblio.biblionumber = subscription.biblionumber
+ ORDER BY title
+ |;
+ $sth = $dbh->prepare($query);
+ } else {
+ my $query = qq|
+ SELECT name,title,planneddate,serialseq,serial.subscriptionid
+ FROM subscription, serial, biblio
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3)
+ AND biblio.biblionumber = subscription.biblionumber
+ ORDER BY title
+ |;
+ $sth = $dbh->prepare($query);
+ }
+ $sth->execute;
+ my @issuelist;
+ my $last_title;
+ 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 ;
+ $count++;
+ push @issuelist,$line;
+ }
+ return $count, at issuelist;
+}
+
+=head2 GetSubscriptionHistoryFromSubscriptionId
+
+=over 4
+
+$sth = GetSubscriptionHistoryFromSubscriptionId()
+this function just prepare the SQL request.
+After this function, don't forget to execute it by using $sth->execute($subscriptionid)
+return :
+$sth = $dbh->prepare($query).
+
+=back
+
+=cut
+sub GetSubscriptionHistoryFromSubscriptionId() {
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT *
+ FROM subscriptionhistory
+ WHERE subscriptionid = ?
+ |;
+ return $dbh->prepare($query);
+}
+
+=head2 GetSerialStatusFromSerialId
+
+=over 4
+
+$sth = GetSerialStatusFromSerialId();
+this function just prepare the SQL request.
+After this function, don't forget to execute it by using $sth->execute($serialid)
+return :
+$sth = $dbh->prepare($query).
+
+=back
+
+=cut
+sub GetSerialStatusFromSerialId(){
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT status
+ FROM serial
+ WHERE serialid = ?
+ |;
+ return $dbh->prepare($query);
+}
+
+
+=head2 GetSubscription
+
+=over 4
+
+$subs = GetSubscription($subscriptionid)
+this function get the subscription which has $subscriptionid as id.
+return :
+a hashref. This hash containts
+subscription, subscriptionhistory, aqbudget.bookfundid, biblio.title
+
+=back
+
+=cut
+sub GetSubscription {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =qq(
+ SELECT subscription.*,
+ subscriptionhistory.*,
+ aqbudget.bookfundid,
+ aqbooksellers.name AS aqbooksellername,
+ biblio.title AS bibliotitle
+ FROM subscription
+ LEFT JOIN subscriptionhistory ON subscription.subscriptionid=subscriptionhistory.subscriptionid
+ 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.subscriptionid = ?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $subs = $sth->fetchrow_hashref;
+ return $subs;
+}
+
+=head2 GetSubscriptionsFromBiblionumber
+
+=over 4
+
+\@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
+
+=cut
+sub GetSubscriptionsFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq(
+ SELECT subscription.*,
+ subscriptionhistory.*,
+ aqbudget.bookfundid,
+ aqbooksellers.name AS aqbooksellername,
+ biblio.title AS bibliotitle
+ FROM subscription
+ LEFT JOIN subscriptionhistory ON subscription.subscriptionid=subscriptionhistory.subscriptionid
+ 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 = ?
+ );
+ 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});
+ $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});
+ }
+ push @res,$subs;
+ }
+ return \@res;
+}
+=head2 GetFullSubscriptionsFromBiblionumber
+
+=over 4
+
+ \@res = GetFullSubscriptionsFromBiblionumber($biblionumber)
+ this function read on serial table.
+
+=back
+
+=cut
+sub GetFullSubscriptionsFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query=qq|
+ SELECT 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
+ 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
+ |;
+
+ 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;
+}
+
+
+=head2 GetSubscriptions
+
+=over 4
+
+ at results = GetSubscriptions($title,$ISSN,$biblionumber);
+this function get all subscriptions which has title like $title,ISSN like $ISSN and biblionumber like $biblionumber.
+return:
+a table of hashref. Each hash containt the subscription.
+
+=back
+
+=cut
+sub GetSubscriptions {
+ my ($title,$ISSN,$biblionumber,$supplierid) = @_;
+ return unless $title or $ISSN or $biblionumber or $supplierid;
+ 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
+ AND biblio.biblionumber=?
+ ORDER BY title
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($biblionumber);
+ } elsif ($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
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($ISSN);
+ }elsif ($supplierid){
+ 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
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($supplierid);
+ } else {
+ 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 ?
+ ORDER BY title
+ );
+ $sth = $dbh->prepare($query);
+ $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;
+ }
+ push @results, $line;
+ }
+ return @results;
+}
+
+=head2 GetSerials
+
+=over 4
+
+($totalissues, at serials) = GetSerials($subscriptionid);
+this function get every serial not arrived 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 GetSerials {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my $counter=0;
+ my @serials;
+
+ # status = 2 is "arrived"
+ my $query = qq|
+ SELECT *
+ FROM serial
+ WHERE subscriptionid = ? AND status NOT IN (2,4,5)
+ |;
+ 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 *
+ FROM serial
+ WHERE subscriptionid = ?
+ AND (status in (2,4,5))
+ ORDER BY serialid DESC
+ |;
+ my $sth=$dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ while((my $line = $sth->fetchrow_hashref) && $counter <5) {
+ $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;
+ }
+ my $query = qq|
+ SELECT count(*)
+ FROM serial
+ WHERE subscriptionid=?
+ |;
+ $sth=$dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($totalissues) = $sth->fetchrow;
+ return ($totalissues, at serials);
+}
+
+=head2 GetLatestSerials
+
+=over 4
+
+\@serials = GetLatestSerials($subscriptionid,$limit)
+get the $limit's latest serials arrived or missing for a given subscription
+return :
+a ref to a table which it containts all of the latest serials stored into a hash.
+
+=back
+
+=cut
+sub GetLatestSerials {
+ my ($subscriptionid,$limit) = @_;
+ my $dbh = C4::Context->dbh;
+ # status = 2 is "arrived"
+ my $strsth=qq(
+ SELECT serialid,serialseq, status, planneddate
+ FROM serial
+ WHERE subscriptionid = ?
+ AND (status =2 or status=4)
+ ORDER BY planneddate DESC LIMIT 0,$limit
+ );
+ 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;
+ }
+# my $query = qq|
+# SELECT count(*)
+# FROM serial
+# WHERE subscriptionid=?
+# |;
+# $sth=$dbh->prepare($query);
+# $sth->execute($subscriptionid);
+# my ($totalissues) = $sth->fetchrow;
+ return \@serials;
+}
+
+=head2 GetDistributedTo
+
+=over 4
+
+$distributedto=GetDistributedTo($subscriptionid)
+This function select the old previous value of distributedto in the database.
+
+=back
+
+=cut
+sub GetDistributedTo {
+ my $dbh = C4::Context->dbh;
+ my $distributedto;
+ my $subscriptionid = @_;
+ my $query = qq|
+ SELECT distributedto
+ FROM subscription
+ WHERE subscriptionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ return ($distributedto) = $sth->fetchrow;
+}
+
+=head2 GetNextSeq
+
+=over 4
+
+GetNextSeq($val)
+$val is a hashref containing all the attributes of the table 'subscription'
+This function get the next issue for the subscription given on input arg
+return:
+all the input params updated.
+
+=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);
+ my $pattern = $val->{numberpattern};
+ 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}){
+ $newlastvalue3 = $val->{setto3};
+ $newlastvalue2++;
+ if($newlastvalue2 > $val->{whenmorethan2}){
+ $newlastvalue1++;
+ $newlastvalue2 = $val->{setto2};
+ }
+ }
+ $calculated =~ s/\{X\}/$newlastvalue1/g;
+ 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;
+ }
+ $calculated =~ s/\{Z\}/$newlastvalue3/g;
+ }
+ 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){
+ 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;
+ }
+ }
+ 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);
+}
+
+
+=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
+
+$calculated = GetSeq($val)
+$val is a hashref containing all the attributes of the table 'subscription'
+this function transforms {X},{Y},{Z} to 150,0,0 for example.
+return:
+the sequence in integer format
+
+=back
+
+=cut
+sub GetSeq {
+ my ($val) =@_;
+ my $calculated = $val->{numberingmethod};
+ my $x=$val->{'lastvalue1'};
+ $calculated =~ s/\{X\}/$x/g;
+ my $y=$val->{'lastvalue2'};
+ $calculated =~ s/\{Y\}/$y/g;
+ my $z=$val->{'lastvalue3'};
+ $calculated =~ s/\{Z\}/$z/g;
+ return $calculated;
+}
+
+=head2 GetSubscriptionExpirationDate
+
+=over 4
+
+$sensddate = GetSubscriptionExpirationDate($subscriptionid)
+
+this function return the expiration date for a subscription given on input args.
+
+return
+the enddate
+
+=back
+
+=cut
+sub GetSubscriptionExpirationDate {
+ 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
+# warn "SUBSCRIPTIONID :$subscriptionid";
+# use Data::Dumper; warn Dumper($subscription);
+
+ if ( $subscription->{numberlength} ) {
+ #calculate the date of the last issue.
+ 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});
+
+ 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;
+}
+
+=head2 CountSubscriptionFromBiblionumber
+
+=over 4
+
+$subscriptionsnumber = CountSubscriptionFromBiblionumber($biblionumber)
+this count the number of subscription for a biblionumber given.
+return :
+the number of subscriptions with biblionumber given on input arg.
+
+=back
+
+=cut
+sub CountSubscriptionFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ 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);
+
+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=?
+ WHERE subscriptionid=?
+ );
+ my $sth = $dbh->prepare($query);
+ $receivedlist =~ s/^,//g;
+ $missinglist =~ s/^,//g;
+ $opacnote =~ s/^,//g;
+ $sth->execute($histstartdate,$enddate,$receivedlist,$missinglist,$opacnote,$librariannote,$subscriptionid);
+}
+
+=head2 ModSerialStatus
+
+=over 4
+
+ModSerialStatus($serialid,$serialseq, $publisheddate,$planneddate,$status,$notes)
+
+This function modify the serial status. Serial status is a number.(eg 2 is "arrived")
+Note : if we change from "waited" to something else,then we will have to create a new "waited" entry
+
+=back
+
+=cut
+sub ModSerialStatus {
+ my ($serialid,$serialseq, $publisheddate,$planneddate,$status,$notes,$itemnumber)=@_;
+
+ # 1st, get previous status :
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT subscriptionid,status
+ 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 {
+ my $query = qq(
+ UPDATE serial
+ SET serialseq=?,publisheddate=?,planneddate=?,status=?,notes=?,itemnumber=?
+ 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 = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($missinglist,$receivedlist) = $sth->fetchrow;
+ if ($status == 2 && $oldstatus != 2) {
+ $receivedlist .= ",$serialseq";
+ }
+ $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 = ?
+ );
+ $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);
+ # 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 = ?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3,$subscriptionid);
+ }
+}
+
+=head2 ModSubscription
+
+=over 4
+
+this function modify a subscription. Put all new values on input args.
+
+=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=?,
+ 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);
+ $sth->finish;
+}
+
+
+=head2 NewSubscription
+
+=over 4
+
+$subscriptionid = &NewSubscription($auser,$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)
+
+Create a new subscription with value given on input args.
+
+return :
+the id of this new subscription
+
+=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) = @_;
+
+ my $dbh = C4::Context->dbh;
+#save subscription (insert into database)
+ my $query = qq|
+ INSERT INTO subscription
+ (librarian,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 (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+ |;
+ 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));
+
+
+#then create the 1st waited number
+ my $subscriptionid = $dbh->{'mysql_insertid'};
+ my $enddate = GetSubscriptionExpirationDate($subscriptionid);
+ my $query = qq(
+ INSERT INTO subscriptionhistory
+ (biblionumber, subscriptionid, histstartdate, enddate, missinglist, receivedlist, 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(
+ SELECT *
+ FROM subscription
+ WHERE subscriptionid = ?
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $val = $sth->fetchrow_hashref;
+
+# calculate issue number
+ my $serialseq = GetSeq($val);
+ my $query = qq|
+ INSERT INTO serial
+ (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));
+ return $subscriptionid;
+}
+
+
+=head2 ReNewSubscription
+
+=over 4
+
+ReNewSubscription($subscriptionid,$user,$startdate,$numberlength,$weeklength,$monthlength,$note)
+
+this function renew a subscription with values given on input args.
+
+=back
+
+=cut
+sub ReNewSubscription {
+ 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|
+ 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);
+}
+
+
+=head2 NewIssue
+
+=over 4
+
+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.
+
+=back
+
+=cut
+sub NewIssue {
+ my ($serialseq,$subscriptionid,$biblionumber,$status, $publisheddate, $planneddate,$itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ INSERT INTO serial
+ (serialseq,subscriptionid,biblionumber,status,publisheddate,planneddate,itemnumber)
+ 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
+ FROM subscriptionhistory
+ WHERE subscriptionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($missinglist,$receivedlist) = $sth->fetchrow;
+ if ($status eq 2) {
+ $receivedlist .= ",$serialseq";
+ }
+ if ($status eq 4) {
+ $missinglist .= ",$serialseq";
+ }
+ my $query = qq|
+ UPDATE subscriptionhistory
+ SET receivedlist=?, missinglist=?
+ WHERE subscriptionid=?
+ |;
+ $sth=$dbh->prepare($query);
+ $sth->execute($receivedlist,$missinglist,$subscriptionid);
+}
+
+=head2 serialchangestatus
+
+=over 4
+
+serialchangestatus($serialid,$serialseq,$planneddate,$status,$notes)
+
+Change the status of a serial issue.
+Note: this was the older subroutine
+
+=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
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select subscriptionid,status from serial where serialid=?");
+ $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;
+ }
+ $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});
+ }
+}
+
+
+
+
+=head2 HasSubscriptionExpired
+
+=over 4
+
+1 or 0 = HasSubscriptionExpired($subscriptionid)
+
+the subscription has expired when the next issue to arrive is out of subscription limit.
+
+return :
+1 if true, 0 if false.
+
+=back
+
+=cut
+sub HasSubscriptionExpired {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $subscription = GetSubscription($subscriptionid);
+ my $expirationdate = GetSubscriptionExpirationDate($subscriptionid);
+ my $query = qq|
+ SELECT max(planneddate)
+ FROM serial
+ WHERE subscriptionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ 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
+
+=over 4
+
+SetDistributedto($distributedto,$subscriptionid);
+This function update the value of distributedto for a subscription given on input arg.
+
+=back
+
+=cut
+sub SetDistributedto {
+ my ($distributedto,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ UPDATE subscription
+ SET distributedto=?
+ WHERE subscriptionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($distributedto,$subscriptionid);
+}
+
+=head2 DelSubscription
+
+=over 4
+
+DelSubscription($subscriptionid)
+this function delete the subscription which has $subscriptionid as id.
+
+=back
+
+=cut
+sub DelSubscription {
+ my ($subscriptionid,$biblionumber) = @_;
+ 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);
+ $dbh->do("DELETE FROM subscription WHERE subscriptionid=$subscriptionid");
+ $dbh->do("DELETE FROM subscriptionhistory WHERE subscriptionid=$subscriptionid");
+ $dbh->do("DELETE FROM serial WHERE subscriptionid=$subscriptionid");
+
+}
+
+=head2 DelIssue
+
+=over 4
+
+DelIssue($serialseq,$subscriptionid)
+this function delete an issue which has $serialseq and $subscriptionid given on input arg.
+
+=back
+
+=cut
+sub DelIssue {
+ my ($serialseq,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ DELETE FROM serial
+ WHERE serialseq= ?
+ AND subscriptionid= ?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($serialseq,$subscriptionid);
+}
+
+=head2 GetMissingIssues
+
+=over 4
+
+($count, at issuelist) = &GetMissingIssues($supplierid,$serialid)
+
+this function select missing issues on database - where serial.status = 4
+
+return :
+a count of the number of missing issues
+the issuelist into a table. Each line of this table containts a ref to a hash which it containts
+name,title,planneddate,serialseq,serial.subscriptionid from tables : subscription, serial & biblio
+
+=back
+
+=cut
+sub GetMissingIssues {
+ my ($supplierid,$serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ 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
+ ");
+ } 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
+ ");
+ }
+ $sth->execute;
+ my @issuelist;
+ my $last_title;
+ 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 ;
+ $count++;
+ push @issuelist,$line;
+ }
+ return $count, at issuelist;
+}
+
+=head2 removeMissingIssue
+
+=over 4
+
+removeMissingIssue($subscriptionid)
+
+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
+
+=back
+
+=cut
+sub removeMissingIssue {
+ my ($sequence,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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){
+ $missinglist =~ s/\|\s\|/\|/g;
+ $missinglist =~ s/^\| //g;
+ $missinglist =~ s/\|$//g;
+ my $sth2= $dbh->prepare("UPDATE subscriptionhistory
+ SET missinglist = ?
+ WHERE subscriptionid = ?");
+ $sth2->execute($missinglist,$subscriptionid);
+ }
+}
+
+=head2 updateClaim
+
+=over 4
+
+&updateClaim($serialid)
+
+this function updates the time when a claim is issued for late/missing items
+
+called from claims.pl file
+
+=back
+
+=cut
+sub updateClaim {
+ my ($serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE serial SET claimdate = now()
+ WHERE serialid = ?
+ ");
+ $sth->execute($serialid);
+}
+
+=head2 getsupplierbyserialid
+
+=over 4
+
+($result) = &getsupplierbyserialid($serialid)
+
+this function is used to find the supplier id given a serial id
+
+return :
+hashref containing serialid, subscriptionid, and aqbooksellerid
+
+=back
+
+=cut
+sub getsupplierbyserialid {
+ my ($serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'};
+ return $result;
+}
+
+=head2 check_routing
+
+=over 4
+
+($result) = &check_routing($subscriptionid)
+
+this function checks to see if a serial has a routing list and returns the count of routingid
+used to show either an 'add' or 'edit' link
+=back
+
+=cut
+sub check_routing {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'};
+ return $result;
+}
+
+=head2 addroutingmember
+
+=over 4
+
+&addroutingmember($bornum,$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
+of either 1 or highest current rank + 1
+
+=back
+
+=cut
+sub addroutingmember {
+ my ($bornum,$subscriptionid) = @_;
+ my $rank;
+ my $dbh = C4::Context->dbh;
+ 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 {
+ $rank = 1;
+ }
+ }
+ $sth = $dbh->prepare("INSERT INTO subscriptionroutinglist VALUES (null,?,?,?,null)");
+ $sth->execute($subscriptionid,$bornum,$rank);
+}
+
+=head2 reorder_members
+
+=over 4
+
+&reorder_members($subscriptionid,$routingid,$rank)
+
+this function is used to reorder the routing list
+
+it takes the routingid of the member one wants to re-rank and the rank it is to move to
+- it gets all members on list puts their routingid's into an array
+- removes the one in the array that is $routingid
+- then reinjects $routingid at point indicated by $rank
+- then update the database with the routingids in the new order
+
+=back
+
+=cut
+sub reorder_members {
+ my ($subscriptionid,$routingid,$rank) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'});
+ }
+ # 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]) {
+ $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]."'");
+ $sth->execute;
+ }
+}
+
+=head2 delroutingmember
+
+=over 4
+
+&delroutingmember($routingid,$subscriptionid)
+
+this function either deletes one member from routing list if $routingid exists otherwise
+deletes all members from the routing list
+
+=back
+
+=cut
+sub delroutingmember {
+ # 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 = ?");
+ $sth->execute($routingid);
+ reorder_members($subscriptionid,$routingid);
+ } else {
+ my $sth = $dbh->prepare("DELETE FROM subscriptionroutinglist WHERE subscriptionid = ?");
+ $sth->execute($subscriptionid);
+ }
+}
+
+=head2 getroutinglist
+
+=over 4
+
+($count, at routinglist) = &getroutinglist($subscriptionid)
+
+this gets the info from the subscriptionroutinglist for $subscriptionid
+
+return :
+a count of the number of members on routinglist
+the routinglist into a table. Each line of this table containts a ref to a hash which containts
+routingid - a unique id, borrowernumber, ranking, and biblionumber of subscription
+
+=back
+
+=cut
+sub getroutinglist {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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) {
+ $count++;
+ push(@routinglist,$line);
+ }
+ return ($count, at routinglist);
+}
+
+=head2 abouttoexpire
+
+=over 4
+
+$result = &abouttoexpire($subscriptionid)
+
+this function alerts you to the penultimate issue for a serial subscription
+
+returns 1 - if this is the penultimate issue
+returns 0 - if not
+
+=back
+
+=cut
+
+sub abouttoexpire {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $subscription = GetSubscription($subscriptionid);
+ my $expirationdate = GetSubscriptionExpirationDate($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;
+ 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 &&
+ 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 GetNextDate
+
+=over 4
+
+($resultdate) = &GetNextDate($planneddate,$subscription)
+
+this function 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
+
+return :
+$resultdate - then next date in the sequence
+
+=back
+
+=cut
+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 = 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);
+ }
+ }
+ @resultdate = Add_Delta_YMD($year,$month, $day, 0, 2,0 );
+ }
+ 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";
+}
+
+
+
+1;
+__END__
Index: Serials.pm
===================================================================
RCS file: Serials.pm
diff -N Serials.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Serials.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,1818 @@
+package C4::Serials; #assumes C4/Serials.pm
+
+# 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: Serials.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+use C4::Date;
+use C4::Suggestions;
+use C4::Biblio;
+use C4::Search;
+use C4::Letters;
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+
+=head1 NAME
+
+C4::Serials - Give functions for serializing.
+
+=head1 SYNOPSIS
+
+ use C4::Serials;
+
+=head1 DESCRIPTION
+
+Give all XYZ functions
+
+=head1 FUNCTIONS
+
+=cut
+ at ISA = qw(Exporter);
+ at 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
+);
+
+=head2 GetSuppliersWithLateIssues
+
+=over 4
+
+%supplierlist = &GetSuppliersWithLateIssues
+
+this function get all suppliers with late issues.
+
+return :
+the supplierlist into a hash. this hash containts id & name of the supplier
+
+=back
+
+=cut
+sub GetSuppliersWithLateIssues {
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT DISTINCT id, name
+ FROM subscription, serial
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND (planneddate < now() OR serial.STATUS = 3 OR serial.STATUS = 4)
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my %supplierlist;
+ while (my ($id,$name) = $sth->fetchrow) {
+ $supplierlist{$id} = $name;
+ }
+ if(C4::Context->preference("RoutingSerials")){
+ $supplierlist{''} = "All Suppliers";
+ }
+ return %supplierlist;
+}
+
+=head2 GetLateIssues
+
+=over 4
+
+ at issuelist = &GetLateIssues($supplierid)
+
+this function select late issues on database
+
+return :
+the issuelist into an table. Each line of this table containts a ref to a hash which it containts
+name,title,planneddate,serialseq,serial.subscriptionid from tables : subscription, serial & biblio
+
+=back
+
+=cut
+sub GetLateIssues {
+ my ($supplierid) = shift;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ($supplierid) {
+ my $query = qq |
+ SELECT name,title,planneddate,serialseq,serial.subscriptionid
+ FROM subscription, serial, biblio
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3)
+ AND subscription.aqbooksellerid=$supplierid
+ AND biblio.biblionumber = subscription.biblionumber
+ ORDER BY title
+ |;
+ $sth = $dbh->prepare($query);
+ } else {
+ my $query = qq|
+ SELECT name,title,planneddate,serialseq,serial.subscriptionid
+ FROM subscription, serial, biblio
+ LEFT JOIN aqbooksellers ON subscription.aqbooksellerid = aqbooksellers.id
+ WHERE subscription.subscriptionid = serial.subscriptionid
+ AND ((planneddate < now() AND serial.STATUS =1) OR serial.STATUS = 3)
+ AND biblio.biblionumber = subscription.biblionumber
+ ORDER BY title
+ |;
+ $sth = $dbh->prepare($query);
+ }
+ $sth->execute;
+ my @issuelist;
+ my $last_title;
+ 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 ;
+ $count++;
+ push @issuelist,$line;
+ }
+ return $count, at issuelist;
+}
+
+=head2 GetSubscriptionHistoryFromSubscriptionId
+
+=over 4
+
+$sth = GetSubscriptionHistoryFromSubscriptionId()
+this function just prepare the SQL request.
+After this function, don't forget to execute it by using $sth->execute($subscriptionid)
+return :
+$sth = $dbh->prepare($query).
+
+=back
+
+=cut
+sub GetSubscriptionHistoryFromSubscriptionId() {
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT *
+ FROM subscriptionhistory
+ WHERE subscriptionid = ?
+ |;
+ return $dbh->prepare($query);
+}
+
+=head2 GetSerialStatusFromSerialId
+
+=over 4
+
+$sth = GetSerialStatusFromSerialId();
+this function just prepare the SQL request.
+After this function, don't forget to execute it by using $sth->execute($serialid)
+return :
+$sth = $dbh->prepare($query).
+
+=back
+
+=cut
+sub GetSerialStatusFromSerialId(){
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT status
+ FROM serial
+ WHERE serialid = ?
+ |;
+ return $dbh->prepare($query);
+}
+
+
+=head2 GetSubscription
+
+=over 4
+
+$subs = GetSubscription($subscriptionid)
+this function get the subscription which has $subscriptionid as id.
+return :
+a hashref. This hash containts
+subscription, subscriptionhistory, aqbudget.bookfundid, biblio.title
+
+=back
+
+=cut
+sub GetSubscription {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query =qq(
+ SELECT subscription.*,
+ subscriptionhistory.*,
+ aqbudget.bookfundid,
+ aqbooksellers.name AS aqbooksellername,
+ biblio.title AS bibliotitle
+ FROM subscription
+ LEFT JOIN subscriptionhistory ON subscription.subscriptionid=subscriptionhistory.subscriptionid
+ 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.subscriptionid = ?
+ );
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $subs = $sth->fetchrow_hashref;
+ return $subs;
+}
+
+=head2 GetSubscriptionsFromBiblionumber
+
+=over 4
+
+\@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
+
+=cut
+sub GetSubscriptionsFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq(
+ SELECT subscription.*,
+ subscriptionhistory.*,
+ aqbudget.bookfundid,
+ aqbooksellers.name AS aqbooksellername,
+ biblio.title AS bibliotitle
+ FROM subscription
+ LEFT JOIN subscriptionhistory ON subscription.subscriptionid=subscriptionhistory.subscriptionid
+ 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 = ?
+ );
+ 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});
+ $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});
+ }
+ push @res,$subs;
+ }
+ return \@res;
+}
+=head2 GetFullSubscriptionsFromBiblionumber
+
+=over 4
+
+ \@res = GetFullSubscriptionsFromBiblionumber($biblionumber)
+ this function read on serial table.
+
+=back
+
+=cut
+sub GetFullSubscriptionsFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query=qq|
+ SELECT 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
+ 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
+ |;
+
+ 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;
+}
+
+
+=head2 GetSubscriptions
+
+=over 4
+
+ at results = GetSubscriptions($title,$ISSN,$biblionumber);
+this function get all subscriptions which has title like $title,ISSN like $ISSN and biblionumber like $biblionumber.
+return:
+a table of hashref. Each hash containt the subscription.
+
+=back
+
+=cut
+sub GetSubscriptions {
+ my ($title,$ISSN,$biblionumber,$supplierid) = @_;
+ return unless $title or $ISSN or $biblionumber or $supplierid;
+ 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
+ AND biblio.biblionumber=?
+ ORDER BY title
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($biblionumber);
+ } elsif ($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
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($ISSN);
+ }elsif ($supplierid){
+ 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
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($supplierid);
+ } else {
+ 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 ?
+ ORDER BY title
+ );
+ $sth = $dbh->prepare($query);
+ $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;
+ }
+ push @results, $line;
+ }
+ return @results;
+}
+
+=head2 GetSerials
+
+=over 4
+
+($totalissues, at serials) = GetSerials($subscriptionid);
+this function get every serial not arrived 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 GetSerials {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my $counter=0;
+ my @serials;
+
+ # status = 2 is "arrived"
+ my $query = qq|
+ SELECT *
+ FROM serial
+ WHERE subscriptionid = ? AND status NOT IN (2,4,5)
+ |;
+ 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 *
+ FROM serial
+ WHERE subscriptionid = ?
+ AND (status in (2,4,5))
+ ORDER BY serialid DESC
+ |;
+ my $sth=$dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ while((my $line = $sth->fetchrow_hashref) && $counter <5) {
+ $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;
+ }
+ my $query = qq|
+ SELECT count(*)
+ FROM serial
+ WHERE subscriptionid=?
+ |;
+ $sth=$dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($totalissues) = $sth->fetchrow;
+ return ($totalissues, at serials);
+}
+
+=head2 GetLatestSerials
+
+=over 4
+
+\@serials = GetLatestSerials($subscriptionid,$limit)
+get the $limit's latest serials arrived or missing for a given subscription
+return :
+a ref to a table which it containts all of the latest serials stored into a hash.
+
+=back
+
+=cut
+sub GetLatestSerials {
+ my ($subscriptionid,$limit) = @_;
+ my $dbh = C4::Context->dbh;
+ # status = 2 is "arrived"
+ my $strsth=qq(
+ SELECT serialid,serialseq, status, planneddate
+ FROM serial
+ WHERE subscriptionid = ?
+ AND (status =2 or status=4)
+ ORDER BY planneddate DESC LIMIT 0,$limit
+ );
+ 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;
+ }
+# my $query = qq|
+# SELECT count(*)
+# FROM serial
+# WHERE subscriptionid=?
+# |;
+# $sth=$dbh->prepare($query);
+# $sth->execute($subscriptionid);
+# my ($totalissues) = $sth->fetchrow;
+ return \@serials;
+}
+
+=head2 GetDistributedTo
+
+=over 4
+
+$distributedto=GetDistributedTo($subscriptionid)
+This function select the old previous value of distributedto in the database.
+
+=back
+
+=cut
+sub GetDistributedTo {
+ my $dbh = C4::Context->dbh;
+ my $distributedto;
+ my $subscriptionid = @_;
+ my $query = qq|
+ SELECT distributedto
+ FROM subscription
+ WHERE subscriptionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ return ($distributedto) = $sth->fetchrow;
+}
+
+=head2 GetNextSeq
+
+=over 4
+
+GetNextSeq($val)
+$val is a hashref containing all the attributes of the table 'subscription'
+This function get the next issue for the subscription given on input arg
+return:
+all the input params updated.
+
+=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);
+ my $pattern = $val->{numberpattern};
+ 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}){
+ $newlastvalue3 = $val->{setto3};
+ $newlastvalue2++;
+ if($newlastvalue2 > $val->{whenmorethan2}){
+ $newlastvalue1++;
+ $newlastvalue2 = $val->{setto2};
+ }
+ }
+ $calculated =~ s/\{X\}/$newlastvalue1/g;
+ 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;
+ }
+ $calculated =~ s/\{Z\}/$newlastvalue3/g;
+ }
+ 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){
+ 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;
+ }
+ }
+ 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);
+}
+
+
+=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
+
+$calculated = GetSeq($val)
+$val is a hashref containing all the attributes of the table 'subscription'
+this function transforms {X},{Y},{Z} to 150,0,0 for example.
+return:
+the sequence in integer format
+
+=back
+
+=cut
+sub GetSeq {
+ my ($val) =@_;
+ my $calculated = $val->{numberingmethod};
+ my $x=$val->{'lastvalue1'};
+ $calculated =~ s/\{X\}/$x/g;
+ my $y=$val->{'lastvalue2'};
+ $calculated =~ s/\{Y\}/$y/g;
+ my $z=$val->{'lastvalue3'};
+ $calculated =~ s/\{Z\}/$z/g;
+ return $calculated;
+}
+
+=head2 GetSubscriptionExpirationDate
+
+=over 4
+
+$sensddate = GetSubscriptionExpirationDate($subscriptionid)
+
+this function return the expiration date for a subscription given on input args.
+
+return
+the enddate
+
+=back
+
+=cut
+sub GetSubscriptionExpirationDate {
+ 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}) {
+ #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) ;
+ }
+ return $enddate;
+}
+
+=head2 CountSubscriptionFromBiblionumber
+
+=over 4
+
+$subscriptionsnumber = CountSubscriptionFromBiblionumber($biblionumber)
+this count the number of subscription for a biblionumber given.
+return :
+the number of subscriptions with biblionumber given on input arg.
+
+=back
+
+=cut
+sub CountSubscriptionFromBiblionumber {
+ my ($biblionumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ 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);
+
+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=?
+ WHERE subscriptionid=?
+ );
+ my $sth = $dbh->prepare($query);
+ $receivedlist =~ s/^,//g;
+ $missinglist =~ s/^,//g;
+ $opacnote =~ s/^,//g;
+ $sth->execute($histstartdate,$enddate,$receivedlist,$missinglist,$opacnote,$librariannote,$subscriptionid);
+}
+
+=head2 ModSerialStatus
+
+=over 4
+
+ModSerialStatus($serialid,$serialseq, $publisheddate,$planneddate,$status,$notes)
+
+This function modify the serial status. Serial status is a number.(eg 2 is "arrived")
+Note : if we change from "waited" to something else,then we will have to create a new "waited" entry
+
+=back
+
+=cut
+sub ModSerialStatus {
+ my ($serialid,$serialseq, $publisheddate,$planneddate,$status,$notes,$itemnumber)=@_;
+
+ # 1st, get previous status :
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ SELECT subscriptionid,status
+ 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 {
+ my $query = qq(
+ UPDATE serial
+ SET serialseq=?,publisheddate=?,planneddate=?,status=?,notes=?,itemnumber=?
+ 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 = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($missinglist,$receivedlist) = $sth->fetchrow;
+ if ($status == 2 && $oldstatus != 2) {
+ $receivedlist .= ",$serialseq";
+ }
+ $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 = ?
+ );
+ $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);
+ # 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 = ?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($newlastvalue1,$newlastvalue2,$newlastvalue3,$newinnerloop1,$newinnerloop2,$newinnerloop3,$subscriptionid);
+ }
+}
+
+=head2 ModSubscription
+
+=over 4
+
+this function modify a subscription. Put all new values on input args.
+
+=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=?,
+ 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);
+ $sth->finish;
+}
+
+
+=head2 NewSubscription
+
+=over 4
+
+$subscriptionid = &NewSubscription($auser,$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)
+
+Create a new subscription with value given on input args.
+
+return :
+the id of this new subscription
+
+=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) = @_;
+
+ my $dbh = C4::Context->dbh;
+#save subscription (insert into database)
+ my $query = qq|
+ INSERT INTO subscription
+ (librarian,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 (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+ |;
+ 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));
+
+
+#then create the 1st waited number
+ my $subscriptionid = $dbh->{'mysql_insertid'};
+ my $enddate = GetSubscriptionExpirationDate($subscriptionid);
+ my $query = qq(
+ INSERT INTO subscriptionhistory
+ (biblionumber, subscriptionid, histstartdate, enddate, missinglist, receivedlist, 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(
+ SELECT *
+ FROM subscription
+ WHERE subscriptionid = ?
+ );
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my $val = $sth->fetchrow_hashref;
+
+# calculate issue number
+ my $serialseq = GetSeq($val);
+ my $query = qq|
+ INSERT INTO serial
+ (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));
+ return $subscriptionid;
+}
+
+
+=head2 ReNewSubscription
+
+=over 4
+
+ReNewSubscription($subscriptionid,$user,$startdate,$numberlength,$weeklength,$monthlength,$note)
+
+this function renew a subscription with values given on input args.
+
+=back
+
+=cut
+sub ReNewSubscription {
+ 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|
+ 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);
+}
+
+
+=head2 NewIssue
+
+=over 4
+
+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.
+
+=back
+
+=cut
+sub NewIssue {
+ my ($serialseq,$subscriptionid,$biblionumber,$status, $publisheddate, $planneddate,$itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ INSERT INTO serial
+ (serialseq,subscriptionid,biblionumber,status,publisheddate,planneddate,itemnumber)
+ 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
+ FROM subscriptionhistory
+ WHERE subscriptionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($subscriptionid);
+ my ($missinglist,$receivedlist) = $sth->fetchrow;
+ if ($status eq 2) {
+ $receivedlist .= ",$serialseq";
+ }
+ if ($status eq 4) {
+ $missinglist .= ",$serialseq";
+ }
+ my $query = qq|
+ UPDATE subscriptionhistory
+ SET receivedlist=?, missinglist=?
+ WHERE subscriptionid=?
+ |;
+ $sth=$dbh->prepare($query);
+ $sth->execute($receivedlist,$missinglist,$subscriptionid);
+}
+
+=head2 serialchangestatus
+
+=over 4
+
+serialchangestatus($serialid,$serialseq,$planneddate,$status,$notes)
+
+Change the status of a serial issue.
+Note: this was the older subroutine
+
+=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
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select subscriptionid,status from serial where serialid=?");
+ $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;
+ }
+ $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});
+ }
+}
+
+
+
+
+=head2 HasSubscriptionExpired
+
+=over 4
+
+1 or 0 = HasSubscriptionExpired($subscriptionid)
+
+the subscription has expired when the next issue to arrive is out of subscription limit.
+
+return :
+1 if true, 0 if false.
+
+=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 $query = qq|
+ SELECT max(planneddate)
+ FROM serial
+ WHERE subscriptionid=?
+ |;
+ 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);
+ return 0;
+ }
+}
+
+=head2 SetDistributedto
+
+=over 4
+
+SetDistributedto($distributedto,$subscriptionid);
+This function update the value of distributedto for a subscription given on input arg.
+
+=back
+
+=cut
+sub SetDistributedto {
+ my ($distributedto,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ UPDATE subscription
+ SET distributedto=?
+ WHERE subscriptionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($distributedto,$subscriptionid);
+}
+
+=head2 DelSubscription
+
+=over 4
+
+DelSubscription($subscriptionid)
+this function delete the subscription which has $subscriptionid as id.
+
+=back
+
+=cut
+sub DelSubscription {
+ my ($subscriptionid,$biblionumber) = @_;
+ 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);
+ $dbh->do("DELETE FROM subscription WHERE subscriptionid=$subscriptionid");
+ $dbh->do("DELETE FROM subscriptionhistory WHERE subscriptionid=$subscriptionid");
+ $dbh->do("DELETE FROM serial WHERE subscriptionid=$subscriptionid");
+
+}
+
+=head2 DelIssue
+
+=over 4
+
+DelIssue($serialseq,$subscriptionid)
+this function delete an issue which has $serialseq and $subscriptionid given on input arg.
+
+=back
+
+=cut
+sub DelIssue {
+ my ($serialseq,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $query = qq|
+ DELETE FROM serial
+ WHERE serialseq= ?
+ AND subscriptionid= ?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($serialseq,$subscriptionid);
+}
+
+=head2 GetMissingIssues
+
+=over 4
+
+($count, at issuelist) = &GetMissingIssues($supplierid,$serialid)
+
+this function select missing issues on database - where serial.status = 4
+
+return :
+a count of the number of missing issues
+the issuelist into a table. Each line of this table containts a ref to a hash which it containts
+name,title,planneddate,serialseq,serial.subscriptionid from tables : subscription, serial & biblio
+
+=back
+
+=cut
+sub GetMissingIssues {
+ my ($supplierid,$serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ 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
+ ");
+ } 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
+ ");
+ }
+ $sth->execute;
+ my @issuelist;
+ my $last_title;
+ 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 ;
+ $count++;
+ push @issuelist,$line;
+ }
+ return $count, at issuelist;
+}
+
+=head2 removeMissingIssue
+
+=over 4
+
+removeMissingIssue($subscriptionid)
+
+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
+
+=back
+
+=cut
+sub removeMissingIssue {
+ my ($sequence,$subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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){
+ $missinglist =~ s/\|\s\|/\|/g;
+ $missinglist =~ s/^\| //g;
+ $missinglist =~ s/\|$//g;
+ my $sth2= $dbh->prepare("UPDATE subscriptionhistory
+ SET missinglist = ?
+ WHERE subscriptionid = ?");
+ $sth2->execute($missinglist,$subscriptionid);
+ }
+}
+
+=head2 updateClaim
+
+=over 4
+
+&updateClaim($serialid)
+
+this function updates the time when a claim is issued for late/missing items
+
+called from claims.pl file
+
+=back
+
+=cut
+sub updateClaim {
+ my ($serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("UPDATE serial SET claimdate = now()
+ WHERE serialid = ?
+ ");
+ $sth->execute($serialid);
+}
+
+=head2 getsupplierbyserialid
+
+=over 4
+
+($result) = &getsupplierbyserialid($serialid)
+
+this function is used to find the supplier id given a serial id
+
+return :
+hashref containing serialid, subscriptionid, and aqbooksellerid
+
+=back
+
+=cut
+sub getsupplierbyserialid {
+ my ($serialid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'};
+ return $result;
+}
+
+=head2 check_routing
+
+=over 4
+
+($result) = &check_routing($subscriptionid)
+
+this function checks to see if a serial has a routing list and returns the count of routingid
+used to show either an 'add' or 'edit' link
+=back
+
+=cut
+sub check_routing {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'};
+ return $result;
+}
+
+=head2 addroutingmember
+
+=over 4
+
+&addroutingmember($bornum,$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
+of either 1 or highest current rank + 1
+
+=back
+
+=cut
+sub addroutingmember {
+ my ($bornum,$subscriptionid) = @_;
+ my $rank;
+ my $dbh = C4::Context->dbh;
+ 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 {
+ $rank = 1;
+ }
+ }
+ $sth = $dbh->prepare("INSERT INTO subscriptionroutinglist VALUES (null,?,?,?,null)");
+ $sth->execute($subscriptionid,$bornum,$rank);
+}
+
+=head2 reorder_members
+
+=over 4
+
+&reorder_members($subscriptionid,$routingid,$rank)
+
+this function is used to reorder the routing list
+
+it takes the routingid of the member one wants to re-rank and the rank it is to move to
+- it gets all members on list puts their routingid's into an array
+- removes the one in the array that is $routingid
+- then reinjects $routingid at point indicated by $rank
+- then update the database with the routingids in the new order
+
+=back
+
+=cut
+sub reorder_members {
+ my ($subscriptionid,$routingid,$rank) = @_;
+ my $dbh = C4::Context->dbh;
+ 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'});
+ }
+ # 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]) {
+ $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]."'");
+ $sth->execute;
+ }
+}
+
+=head2 delroutingmember
+
+=over 4
+
+&delroutingmember($routingid,$subscriptionid)
+
+this function either deletes one member from routing list if $routingid exists otherwise
+deletes all members from the routing list
+
+=back
+
+=cut
+sub delroutingmember {
+ # 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 = ?");
+ $sth->execute($routingid);
+ reorder_members($subscriptionid,$routingid);
+ } else {
+ my $sth = $dbh->prepare("DELETE FROM subscriptionroutinglist WHERE subscriptionid = ?");
+ $sth->execute($subscriptionid);
+ }
+}
+
+=head2 getroutinglist
+
+=over 4
+
+($count, at routinglist) = &getroutinglist($subscriptionid)
+
+this gets the info from the subscriptionroutinglist for $subscriptionid
+
+return :
+a count of the number of members on routinglist
+the routinglist into a table. Each line of this table containts a ref to a hash which containts
+routingid - a unique id, borrowernumber, ranking, and biblionumber of subscription
+
+=back
+
+=cut
+sub getroutinglist {
+ my ($subscriptionid) = @_;
+ my $dbh = C4::Context->dbh;
+ 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) {
+ $count++;
+ push(@routinglist,$line);
+ }
+ return ($count, at routinglist);
+}
+
+=head2 abouttoexpire
+
+=over 4
+
+$result = &abouttoexpire($subscriptionid)
+
+this function alerts you to the penultimate issue for a serial subscription
+
+returns 1 - if this is the penultimate issue
+returns 0 - if not
+
+=back
+
+=cut
+
+sub abouttoexpire {
+ 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 $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});
+ # warn "DATE BEFORE END: $datebeforeend";
+ return 1 if ($res >= $datebeforeend && $res < $endofsubscriptiondate);
+ return 0;
+ }
+}
+
+
+
+=head2 GetNextDate
+
+=over 4
+
+($resultdate) = &GetNextDate($planneddate,$subscription)
+
+this function 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
+
+return :
+$resultdate - then next date in the sequence
+
+=back
+
+=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; }
+
+ if($irreghash{$dayofweek+1}){
+ $planneddate = DATE_Add_Duration($planneddate,$duration);
+ $dayofweek++;
+ }
+ }
+ $resultdate=DATE_Add_Duration($planneddate,$duration);
+ }
+ 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);
+ }
+ # warn "date: ".$resultdate;
+ return $resultdate;
+}
+
+
+
+1;
+__END__
Index: Stats.pm
===================================================================
RCS file: Stats.pm
diff -N Stats.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Stats.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,245 @@
+package C4::Stats;
+
+# $Id: Stats.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+# Modified by TG
+# 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
+
+use strict;
+require Exporter;
+
+use C4::Context;
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Stats - Update Koha statistics (log)
+
+=head1 SYNOPSIS
+
+ use C4::Stats;
+
+=head1 DESCRIPTION
+
+The C<&UpdateStats> function adds an entry to the statistics table in
+the Koha database, which acts as an activity log.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&UpdateStats &statsreport &TotalOwing
+&TotalPaid &getcharges &Getpaidbranch &unfilledreserves &getcredits &getinvoices);
+
+=item UpdateStats
+
+ &UpdateStats($env, $branch, $type, $value, $other, $itemnumber,
+ $itemtype, $borrowernumber);
+
+Adds a line to the statistics table of the Koha database. In effect,
+it logs an event.
+
+C<$branch>, C<$type>, C<$value>, C<$other>, C<$itemnumber>,
+C<$itemtype>, and C<$borrowernumber> correspond to the fields of the
+statistics table in the Koha database.
+
+If C<$branch> is the empty string, the branch code will be taken from
+C<$env-E<gt>{branchcode}>.
+
+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 $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;
+ # 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);
+ $sth->finish;
+}
+
+# Otherwise, it'd need a POD.
+sub TotalPaid {
+ my ($time,$time2)=@_;
+ $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);
+ }
+
+
+
+
+ $query.=" order by timestamp";
+
+ # print $query;
+
+ my $sth=$dbh->prepare($query);
+
+ # $sth->execute();
+ $sth->execute(@bind);
+ my @results;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ # print $query;
+ return(@results);
+}
+
+# Otherwise, it needs a POD.
+sub getcharges{
+ my($borrowerno,$offset,$accountno)=@_;
+ my $dbh = C4::Context->dbh;
+ 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);
+
+ # 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);
+ }
+
+ # print $query,"<br>";
+ my $i=0;
+ my @results;
+ while (my $data=$sth->fetchrow_hashref){
+ # if ($data->{'timestamp'} == $timestamp){
+ $results[$i]=$data;
+ $i++;
+ # }
+ }
+ return(@results);
+}
+
+# Otherwise, it needs a POD.
+sub getcredits{
+ my ($date,$date2)=@_;
+ my $dbh = C4::Context->dbh;
+
+
+
+ my $sth=$dbh->prepare("Select * from accountlines,borrowers where (( (accounttype <> 'Pay'))
+ and amount < 0 and accountlines.borrowernumber = borrowers.borrowernumber
+ and date >=? and date <=?)");
+ $sth->execute($date, $date2);
+
+ my $i=0;
+ my @results;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ return(@results);
+}
+
+sub getinvoices{
+ 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;
+ my @results;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ return(@results);
+}
+
+
+# Otherwise, this needs a POD.
+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);
+ # print $query;
+ my $data=$sth->fetchrow_hashref;
+ $sth->finish;
+ return($data->{'branch'});
+}
+
+# FIXME - This is only used in reservereport.pl and reservereport.xls,
+# neither of which is used.
+# 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
+ is NULL and biblio.biblionumber=reserves.biblionumber and
+ reserves.borrowernumber=borrowers.borrowernumber
+ order by
+ reserves.reservedate,biblio.title");
+ $sth->execute;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return($i,\@results);
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
+
Index: Suggestions.pm
===================================================================
RCS file: Suggestions.pm
diff -N Suggestions.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Suggestions.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,466 @@
+package C4::Suggestions;
+
+# 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: Suggestions.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Output;
+use Mail::Sendmail;
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+=head1 NAME
+
+C4::Suggestions - Some useful functions for dealings with suggestions.
+
+=head1 SYNOPSIS
+
+use C4::Suggestions;
+
+=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"
+
+When a librarian manages the suggestion, he can set the status to "REJECTED" or "ACCEPTED".
+
+When the book is ordered, the suggestion status becomes "ORDERED"
+
+When a book is ordered and arrived in the library, the status becomes "AVAILABLE"
+
+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
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &NewSuggestion
+ &SearchSuggestion
+ &GetSuggestion
+ &DelSuggestion
+ &CountSuggestion
+ &ModStatus
+ &ConnectSuggestionAndBiblio
+ &GetSuggestionFromBiblionumber
+ );
+
+=head2 SearchSuggestion
+
+=over 4
+
+(\@array) = &SearchSuggestion($user,$author,$title,$publishercode,$status,$suggestedbyme)
+
+searches for a suggestion
+
+return :
+C<\@array> : the suggestions found. Array of hash.
+Note the status is stored twice :
+* 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|
+ 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 1=1 |;
+
+ my @sql_params;
+ if ($author) {
+ push @sql_params,"%".$author."%";
+ $query .= " and author like ?";
+ }
+ if ($title) {
+ push @sql_params,"%".$title."%";
+ $query .= " and suggestions.title like ?";
+ }
+ if ($publishercode) {
+ 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) {
+ unless ($userenv->{flags} == 1){
+ push @sql_params,$userenv->{branch};
+ $query .= " and (U1.branchcode = ? or U1.branchcode ='')";
+ }
+ }
+ }
+ if ($suggestedbyme) {
+ unless ($suggestedbyme eq -1) {
+ push @sql_params,$user;
+ $query .= " and suggestedby=?";
+ }
+ } else {
+ $query .= " and managedby is NULL";
+ }
+ my $sth=$dbh->prepare($query);
+ $sth->execute(@sql_params);
+ my @results;
+ my $even=1; # the even variable is used to set even / odd lines, for highlighting
+ while (my $data=$sth->fetchrow_hashref){
+ $data->{$data->{STATUS}} = 1;
+ if ($even) {
+ $even=0;
+ $data->{even}=1;
+ } else {
+ $even=1;
+ }
+ push(@results,$data);
+ }
+ return (\@results);
+}
+
+=head2 GetSuggestion
+
+=over 4
+
+\%sth = &GetSuggestion($suggestionid)
+
+this function get the detail of the suggestion $suggestionid (input arg)
+
+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|
+ SELECT *
+ FROM suggestions
+ WHERE suggestionid=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($suggestionid);
+ return($sth->fetchrow_hashref);
+}
+
+=head2 GetSuggestionFromBiblionumber
+
+=over 4
+
+$suggestionid = &GetSuggestionFromBiblionumber($dbh,$biblionumber)
+
+Get a suggestion from it's biblionumber.
+
+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|
+ SELECT suggestionid
+ FROM suggestions
+ WHERE biblionumber=?
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($biblionumber);
+ my ($suggestionid) = $sth->fetchrow;
+ return $suggestionid;
+}
+
+
+=head2 CountSuggestion
+
+=over 4
+
+&CountSuggestion($status)
+
+Count the number of suggestions with the status given on input argument.
+the arg status can be :
+
+=over
+
+=over
+
+=item * ASKED : asked by the user, not dealed by the librarian
+
+=item * ACCEPTED : accepted by the librarian, but not yet ordered
+
+=item * REJECTED : rejected by the librarian (definitive status)
+
+=item * ORDERED : ordered by the librarian (acquisition module)
+
+=back
+
+=back
+
+return :
+the number of suggestion with this status.
+
+=back
+
+=cut
+sub CountSuggestion {
+ my ($status) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if (C4::Context->preference("IndependantBranches")){
+ my $userenv = C4::Context->userenv;
+ if ($userenv->{flags} == 1){
+ my $query = qq |
+ SELECT count(*)
+ FROM suggestions
+ WHERE status=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status);
+ }
+ else {
+ my $query = qq |
+ SELECT count(*)
+ FROM suggestions,borrowers
+ WHERE status=?
+ AND borrowers.borrowernumber=suggestions.suggestedby
+ AND (borrowers.branchcode='' OR borrowers.branchcode =?)
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status,$userenv->{branch});
+ }
+ }
+ else {
+ my $query = qq |
+ SELECT count(*)
+ FROM suggestions
+ WHERE status=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status);
+ }
+ my ($result) = $sth->fetchrow;
+ return $result;
+}
+
+=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 $dbh = C4::Context->dbh;
+
+ my $query = qq |
+ INSERT INTO suggestions
+ (status,suggestedby,title,author,publishercode,note,copyrightdate,
+ volumedesc,publicationyear,place,isbn,biblionumber)
+ VALUES ('ASKED',?,?,?,?,?,?,?,?,?,?,?)
+ |;
+ my $sth = $dbh->prepare($query);
+ $sth->execute($borrowernumber,$title,$author,$publishercode,$note,$copyrightdate,$volumedesc,$publicationyear,$place,$isbn,$biblionumber);
+}
+
+=head2 ModStatus
+
+=over 4
+
+&ModStatus($suggestionid,$status,$managedby,$biblionumber)
+
+Modify the status (status can be 'ASKED', 'ACCEPTED', 'REJECTED', 'ORDERED')
+and send a mail to notify the user that did the suggestion.
+
+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 $dbh = C4::Context->dbh;
+ my $sth;
+ if ($managedby>0) {
+ if ($biblionumber) {
+ my $query = qq|
+ UPDATE suggestions
+ SET status=?,managedby=?,biblionumber=?
+ WHERE suggestionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status,$managedby,$biblionumber,$suggestionid);
+ } else {
+ my $query = qq|
+ UPDATE suggestions
+ SET status=?,managedby=?
+ WHERE suggestionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status,$managedby,$suggestionid);
+ }
+ } else {
+ if ($biblionumber) {
+ my $query = qq|
+ UPDATE suggestions
+ SET status=?,biblionumber=?
+ WHERE suggestionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status,$biblionumber,$suggestionid);
+ }
+ else {
+ my $query = qq|
+ UPDATE suggestions
+ SET status=?
+ WHERE suggestionid=?
+ |;
+ $sth = $dbh->prepare($query);
+ $sth->execute($status,$suggestionid);
+ }
+ }
+ # check mail sending.
+ my $queryMail = qq|
+ SELECT suggestions.*,
+ boby.surname AS bysurname,
+ boby.firstname AS byfirstname,
+ boby.emailaddress AS byemail,
+ lib.surname AS libsurname,
+ lib.firstname AS libfirstname,
+ lib.emailaddress 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);
+
+ $template->param(
+ byemail => $emailinfo->{byemail},
+ libemail => $emailinfo->{libemail},
+ status => $emailinfo->{status},
+ title => $emailinfo->{title},
+ author =>$emailinfo->{author},
+ libsurname => $emailinfo->{libsurname},
+ libfirstname => $emailinfo->{libfirstname},
+ byfirstname => $emailinfo->{byfirstname},
+ bysurname => $emailinfo->{bysurname},
+ );
+ my %mail = (
+ To => $emailinfo->{byemail},
+ From => $emailinfo->{libemail},
+ Subject => 'Koha suggestion',
+ Message => "".$template->output
+ );
+ 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 |
+ 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 |
+ 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|
+ DELETE FROM suggestions
+ WHERE suggestionid=?
+ |;
+ $sth = $dbh->prepare($queryDelete);
+ $sth->execute($suggestionid);
+ }
+}
+
+1;
+__END__;
\ No newline at end of file
Index: Z3950.pm
===================================================================
RCS file: Z3950.pm
diff -N Z3950.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Z3950.pm 10 Mar 2007 01:35:34 -0000 1.1.2.1
@@ -0,0 +1,380 @@
+package C4::Z3950;
+
+# $Id: Z3950.pm,v 1.1.2.1 2007/03/10 01:35:34 tgarip1957 Exp $
+
+# Routines for handling Z39.50 lookups
+
+# Koha library project www.koha.org
+
+# Licensed under the GPL
+
+
+# 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
+
+use strict;
+
+# standard or CPAN modules used
+
+# Koha modules used
+use C4::Context;
+use C4::Input;
+use C4::Biblio;
+
+#------------------
+
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Z3950 - Functions dealing with Z39.50 queries
+
+=head1 SYNOPSIS
+
+ use C4::Z3950;
+
+=head1 DESCRIPTION
+
+This module contains functions for looking up Z39.50 servers, and for
+entering Z39.50 lookup requests.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &getz3950servers
+ &z3950servername
+ &addz3950queue
+ &checkz3950searchdone
+);
+
+#------------------------------------------------
+=item getz3950servers
+
+ @servers= &getz3950servers(checked);
+
+Returns the list of declared z3950 servers
+
+C<$checked> should always be true (1) => returns only active servers.
+If 0 => returns all servers
+
+=cut
+sub getz3950servers {
+ my ($checked) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ($checked) {
+ $sth = $dbh->prepare("select * from z3950servers where checked=1");
+ } else {
+ $sth = $dbh->prepare("select * from z3950servers");
+ }
+ my @result;
+ while ( my ($host, $port, $db, $userid, $password,$servername) = $sth->fetchrow ) {
+ push @result, "$servername/$host\:$port/$db/$userid/$password";
+ } # while
+ return @result;
+}
+
+=item z3950servername
+
+ $name = &z3950servername($dbh, $server_id, $default_name);
+
+Looks up a Z39.50 server by ID number, and returns its full name. If
+the server is not found, returns C<$default_name>.
+
+C<$server_id> is the Z39.50 server ID to look up.
+
+C<$dbh> is ignored.
+
+=cut
+#'
+
+sub z3950servername {
+ # inputs
+ my ($srvid, # server id number
+ $default,)=@_;
+ # return
+ my $longname;
+ #----
+
+ my $dbh = C4::Context->dbh;
+
+ my $sti=$dbh->prepare("select name from z3950servers where id=?");
+
+ $sti->execute($srvid);
+ if ( ! $sti->err ) {
+ ($longname)=$sti->fetchrow;
+ }
+ if (! $longname) {
+ $longname="$default";
+ }
+ return $longname;
+} # sub z3950servername
+
+#---------------------------------------
+
+=item addz3950queue
+
+ $errmsg = &addz3950queue($query, $type, $request_id, @servers);
+
+Adds a Z39.50 search query for the Z39.50 server to look up.
+
+C<$query> is the term to search for.
+
+C<$type> is the query type, e.g. C<isbn>, C<lccn>, etc.
+
+C<$request_id> is a unique string that will identify this query.
+
+C<@servers> is a list of servers to query (obviously, this can be
+given either as an array, or as a list of scalars). Each element may
+be either a Z39.50 server ID from the z3950server table of the Koha
+database, the string C<DEFAULT> or C<CHECKED>, or a complete server
+specification containing a colon.
+
+C<DEFAULT> and C<CHECKED> are synonymous, and refer to those servers
+in the z3950servers table whose 'checked' field is set and non-NULL.
+
+Once the query has been submitted to the Z39.50 daemon,
+C<&addz3950queue> sends a SIGHUP to the daemon to tell it to process
+this new request.
+
+C<&addz3950queue> returns an error message. If it was successful, the
+error message is the empty string.
+
+=cut
+#'
+sub addz3950queue {
+ use strict;
+ # input
+ my (
+ $query, # value to look up
+ $type, # type of value ("isbn", "lccn", "title", "author", "keyword")
+ $requestid, # Unique value to prevent duplicate searches from multiple HTML form submits
+ @z3950list, # list of z3950 servers to query
+ )=@_;
+ # Returns:
+ my $error;
+
+ my (
+ $sth,
+ @serverlist,
+ $server,
+ $failed,
+ $servername,
+ );
+
+ # FIXME - Should be configurable, probably in /etc/koha.conf.
+ my $pidfile='/var/log/koha/processz3950queue.pid';
+
+ $error="";
+
+ my $dbh = C4::Context->dbh;
+ # list of servers: entry can be a fully qualified URL-type entry
+ # or simply just a server ID number.
+ foreach $server (@z3950list) {
+ if ($server =~ /:/ ) {
+ push @serverlist, $server;
+ } elsif ($server eq 'DEFAULT' || $server eq 'CHECKED' ) {
+ $sth=$dbh->prepare("select host,port,db,userid,password ,name,syntax from z3950servers where checked <> 0 ");
+ $sth->execute;
+ while ( my ($host, $port, $db, $userid, $password,$servername,$syntax) = $sth->fetchrow ) {
+ push @serverlist, "$servername/$host\:$port/$db/$userid/$password/$syntax";
+ } # while
+ } else {
+ $sth=$dbh->prepare("select host,port,db,userid,password,syntax from z3950servers where id=? ");
+ $sth->execute($server);
+ my ($host, $port, $db, $userid, $password,$syntax) = $sth->fetchrow;
+ push @serverlist, "$server/$host\:$port/$db/$userid/$password/$syntax";
+ }
+ }
+
+ my $serverlist='';
+
+ $serverlist = join("|", @serverlist);
+# chop $serverlist;
+
+ # FIXME - Is this test supposed to test whether @serverlist is
+ # empty? If so, then a) there are better ways to do that in
+ # Perl (e.g., "if (@serverlist eq ())"), and b) it doesn't
+ # work anyway, since it checks whether $serverlist is composed
+ # of one or more spaces, which is never the case, not even
+ # when there are 0 or 1 elements in @serverlist.
+ if ( $serverlist !~ /^ +$/ ) {
+ # Don't allow reinsertion of the same request identifier.
+ $sth=$dbh->prepare("select identifier from z3950queue
+ where identifier=?");
+ $sth->execute($requestid);
+ if ( ! $sth->rows) {
+ $sth=$dbh->prepare("insert into z3950queue (term,type,servers, identifier) values (?, ?, ?, ?)");
+ $sth->execute($query, $type, $serverlist, $requestid);
+ if ( -r $pidfile ) {
+ # FIXME - Perl is good at opening files. No need to
+ # spawn a separate 'cat' process.
+ my $pid=`cat $pidfile`;
+ chomp $pid;
+ warn "PID : $pid";
+ # Kill -HUP the Z39.50 daemon to tell it to process
+ # this query.
+ my $processcount=kill 1, $pid;
+ if ($processcount==0) {
+ $error.="Z39.50 search daemon error: no process signalled. ";
+ }
+ } else {
+ # FIXME - Error-checking like this should go close
+ # to the test.
+ $error.="No Z39.50 search daemon running: no file $pidfile. ";
+ } # if $pidfile
+ } else {
+ # FIXME - Error-checking like this should go close
+ # to the test.
+ $error.="Duplicate request ID $requestid. ";
+ } # if rows
+ } else {
+ # FIXME - Error-checking like this should go close to the
+ # test. I.e.,
+ # return "No Z39.50 search servers specified. "
+ # if @serverlist eq ();
+
+ # server list is empty
+ $error.="No Z39.50 search servers specified. ";
+ } # if serverlist empty
+
+ return $error;
+
+} # sub addz3950queue
+
+=item &checkz3950searchdone
+
+ $numberpending= & &checkz3950searchdone($random);
+
+Returns the number of pending z3950 requests
+
+C<$random> is the random z3950 query number.
+
+=cut
+sub checkz3950searchdone {
+ my ($z3950random) = @_;
+ my $dbh = C4::Context->dbh;
+ # first, check that the deamon already created the requests...
+ my $sth = $dbh->prepare("select count(*) from z3950queue,z3950results where z3950queue.id = z3950results.queryid and z3950queue.identifier=?");
+ $sth->execute($z3950random);
+ my ($result) = $sth->fetchrow;
+ if ($result eq 0) { # search not yet begun => should be searches to do !
+ return "??";
+ }
+ # second, count pending requests
+ $sth = $dbh->prepare("select count(*) from z3950queue,z3950results where z3950queue.id = z3950results.queryid and z3950results.enddate is null and z3950queue.identifier=?");
+ $sth->execute($z3950random);
+ ($result) = $sth->fetchrow;
+ return $result;
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
+
+#--------------------------------------
+# $Log: Z3950.pm,v $
+# Revision 1.1.2.1 2007/03/10 01:35:34 tgarip1957
+# fresh files for rel_TG
+#
+# Revision 1.13 2006/09/06 16:21:03 tgarip1957
+# Clean up before final commits
+#
+# Revision 1.10 2003/10/01 15:08:14 tipaul
+# fix fog bug #622 : processz3950queue fails
+#
+# Revision 1.9 2003/04/29 16:50:51 tipaul
+# really proud of this commit :-)
+# z3950 search and import seems to works fine.
+# Let me explain how :
+# * a "search z3950" button is added in the addbiblio template.
+# * when clicked, a popup appears and z3950/search.pl is called
+# * z3950/search.pl calls addz3950search in the DB
+# * the z3950 daemon retrieve the records and stores them in z3950results AND in marc_breeding table.
+# * as long as there as searches pending, the popup auto refresh every 2 seconds, and says how many searches are pending.
+# * when the user clicks on a z3950 result => the parent popup is called with the requested biblio, and auto-filled
+#
+# Note :
+# * character encoding support : (It's a nightmare...) In the z3950servers table, a "encoding" column has been added. You can put "UNIMARC" or "USMARC" in this column. Depending on this, the char_decode in C4::Biblio.pm replaces marc-char-encode by an iso 8859-1 encoding. Note that in the breeding import this value has been added too, for a better support.
+# * the marc_breeding and z3950* tables have been modified : they have an encoding column and the random z3950 number is stored too for convenience => it's the key I use to list only requested biblios in the popup.
+#
+# Revision 1.8 2003/04/29 08:09:45 tipaul
+# z3950 support is coming...
+# * adding a syntax column in z3950 table = this column will say wether the z3950 must be called with PerferedRecordsyntax => USMARC or PerferedRecordsyntax => UNIMARC. I tried some french UNIMARC z3950 servers, and some only send USMARC, some only UNIMARC, some can answer with both.
+# Note this is a 1st draft. More to follow (today ? I hope).
+#
+# Revision 1.7 2003/02/19 01:01:06 wolfpac444
+# Removed the unecessary $dbh argument from being passed.
+# Resolved a few minor FIXMEs.
+#
+# Revision 1.6 2002/10/13 08:30:53 arensb
+# Deleted unused variables.
+# Removed trailing whitespace.
+#
+# Revision 1.5 2002/10/13 06:13:23 arensb
+# Removed bogus #! line (this isn't a script!)
+# Removed unused global variables.
+# Added POD.
+# Added some explanatory comments.
+# Added some FIXME comments.
+#
+# Revision 1.4 2002/10/11 12:35:35 arensb
+# Replaced &requireDBI with C4::Context->dbh
+#
+# Revision 1.3 2002/08/14 18:12:52 tonnesen
+# Added copyright statement to all .pl and .pm files
+#
+# Revision 1.2 2002/07/02 20:31:33 tonnesen
+# module added from rel-1-2 branch
+#
+# Revision 1.1.2.5 2002/06/29 17:33:47 amillar
+# Allow DEFAULT as input to addz3950search.
+# Check for existence of pid file (cat crashed otherwise).
+# Return error messages in addz3950search.
+#
+# Revision 1.1.2.4 2002/06/28 18:07:27 tonnesen
+# marcimport.pl will print an error message if it can not signal the
+# processz3950queue program. The message contains instructions for starting the
+# daemon.
+#
+# Revision 1.1.2.3 2002/06/28 17:45:39 tonnesen
+# z3950queue now listens for a -HUP signal before processing the queue. Z3950.pm
+# sends the -HUP signal when queries are added to the queue.
+#
+# Revision 1.1.2.2 2002/06/26 20:54:31 tonnesen
+# use warnings breaks on perl 5.005...
+#
+# Revision 1.1.2.1 2002/06/26 07:26:41 amillar
+# New module for Z39.50 searching
+#
More information about the Koha-cvs
mailing list