gitea
/
Koha-clms
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Bug 38664: Tidy the whole codebase 

This commit is generated using:
  % perl misc/devel/tidy.pl
*within* ktd, to get the same version of perltidy than what will be used
by our CI (currently v20230309).

Signed-off-by: Katrin Fischer <katrin.fischer@bsz-bw.de>
This commit is contained in:
Koha Development Team 2025-01-27 13:21:28 +01:00 committed by Katrin Fischer
parent 6e79bc2dd4
commit d659526b5a
No known key found for this signature in database
GPG Key ID: 0EF6E2C03357A834
3215 changed files with 264951 additions and 236423 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.prettierrc.js
View File

@ -17,7 +17,7 @@ module.exports = {
trailingComma: "es5",
arrowParens: "avoid",
semi: false,
}
},
},
{
files: ["*.tt", "*.inc"],
@ -29,4 +29,4 @@ module.exports = {
},
},
],
}
};

6
C4/Accounts.pm
View File

@ -17,7 +17,6 @@ package C4::Accounts;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Context;
use C4::Stats;
@ -27,7 +26,6 @@ use Koha::Account::Lines;
use Koha::Account::Offsets;
use Koha::Items;
use vars qw(@ISA @EXPORT);
BEGIN {
@ -77,6 +75,7 @@ sub chargelostitem {
my $processfee = $itype->processfee;
my $usedefaultreplacementcost = C4::Context->preference("useDefaultReplacementCost");
my $processingfeenote = C4::Context->preference("ProcessingFeeNote");
if ( $usedefaultreplacementcost && $replacementprice == 0 && $defaultreplacecost ) {
$replacementprice = $defaultreplacecost;
}
@ -88,6 +87,7 @@ sub chargelostitem {
my $issue_id = $checkout ? $checkout->issue_id : undef;
my $account = Koha::Account->new( { patron_id => $borrowernumber } );
# first make sure the borrower hasn't already been charged for this item (for this issuance)
my $existing_charges = $account->lines->search(
{
@ -99,6 +99,7 @@ sub chargelostitem {
# OK, they haven't
unless ($existing_charges) {
#add processing fee
if ( $processfee && $processfee > 0 ) {
my $accountline = $account->add_debit(
@ -115,6 +116,7 @@ sub chargelostitem {
}
);
}
#add replace cost
if ( $replacementprice > 0 ) {
my $accountline = $account->add_debit(

238
C4/Acquisition.pm
View File

@ -17,7 +17,6 @@ package C4::Acquisition;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use Carp qw( carp croak );
use Text::CSV_XS;
@ -46,8 +45,8 @@ use C4::Koha;
use MARC::Field;
use JSON qw( to_json );
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -96,10 +95,6 @@ BEGIN {
);
}
sub GetOrderFromItemnumber {
my ($itemnumber) = @_;
my $dbh = C4::Context->dbh;
@ -185,13 +180,13 @@ The other parameters are optional, see ModBasketHeader for more info on them.
=cut
sub NewBasket {
my ( $booksellerid, $authorisedby, $basketname, $basketnote,
my (
$booksellerid, $authorisedby, $basketname, $basketnote,
$basketbooksellernote, $basketcontractnumber, $deliveryplace,
$billingplace, $is_standing, $create_items ) = @_;
$billingplace, $is_standing, $create_items
) = @_;
my $dbh = C4::Context->dbh;
my $query =
'INSERT INTO aqbasket (creationdate,booksellerid,authorisedby) '
. 'VALUES (now(),?,?)';
my $query = 'INSERT INTO aqbasket (creationdate,booksellerid,authorisedby) ' . 'VALUES (now(),?,?)';
$dbh->do( $query, {}, $booksellerid, $authorisedby );
my $basket = $dbh->{mysql_insertid};
@ -210,8 +205,10 @@ sub NewBasket {
);
}
ModBasketHeader( $basket, $basketname, $basketnote, $basketbooksellernote,
$basketcontractnumber, $booksellerid, $deliveryplace, $billingplace, $is_standing, $create_items );
ModBasketHeader(
$basket, $basketname, $basketnote, $basketbooksellernote,
$basketcontractnumber, $booksellerid, $deliveryplace, $billingplace, $is_standing, $create_items
);
return $basket;
}
@ -229,12 +226,14 @@ sub ReopenBasket {
my $dbh = C4::Context->dbh;
$dbh->do( q{UPDATE aqbasket SET closedate=NULL WHERE basketno=?}, {}, $basketno );
$dbh->do( q{
$dbh->do(
q{
UPDATE aqorders
SET orderstatus = 'new'
WHERE basketno = ?
AND orderstatus NOT IN ( 'complete', 'cancelled' )
}, {}, $basketno);
}, {}, $basketno
);
# Log the basket reopening
if ( C4::Context->preference("AcquisitionLog") ) {
@ -265,9 +264,7 @@ sub GetBasketAsCSV {
my ( $basketno, $cgi, $csv_profile_id ) = @_;
my $basket = GetBasket($basketno);
my @orders = GetOrders($basketno);
my $contract = GetContract({
contractnumber => $basket->{'contractnumber'}
});
my $contract = GetContract( { contractnumber => $basket->{'contractnumber'} } );
my $template = C4::Templates::gettemplate( "acqui/csv/basket.tt", "intranet", $cgi );
my @rows;
@ -288,12 +285,14 @@ sub GetBasketAsCSV {
);
my $csv_profile_content = $csv_profile->content;
my ( @headers, @fields );
while ( $csv_profile_content =~ /
while (
$csv_profile_content =~ /
([^=\|]+) # header
=?
([^\|]*) # fieldname (table.row or row)
\|? /gxms
) {
)
{
my $header = $1;
my $field = ( $2 eq '' ) ? $1 : $2;
@ -325,8 +324,7 @@ sub GetBasketAsCSV {
$content .= $string . "\n";
}
return $content;
}
else {
} else {
foreach my $order (@orders) {
my $biblio = Koha::Biblios->find( $order->{biblionumber} );
my $biblioitem;
@ -349,13 +347,16 @@ sub GetBasketAsCSV {
};
for my $place (qw( deliveryplace billingplace )) {
if ( my $library = Koha::Libraries->find( $row->{deliveryplace} ) ) {
$row->{$place} = $library->branchname
$row->{$place} = $library->branchname;
}
}
foreach(qw(
foreach (
qw(
contractname author title publishercode collectiontitle notes
deliveryplace billingplace
) ) {
)
)
{
# Double the quotes to not be interpreted as a field end
$row->{$_} =~ s/"/""/g if $row->{$_};
}
@ -374,7 +375,6 @@ sub GetBasketAsCSV {
}
}
=head3 GetBasketGroupAsCSV
&GetBasketGroupAsCSV($basketgroupid);
@ -394,9 +394,7 @@ sub GetBasketGroupAsCSV {
my @rows;
for my $basket (@$baskets) {
my @orders = GetOrders( $basket->{basketno} );
my $contract = GetContract({
contractnumber => $basket->{contractnumber}
});
my $contract = GetContract( { contractnumber => $basket->{contractnumber} } );
my $bookseller = Koha::Acquisition::Booksellers->find( $basket->{booksellerid} );
my $basketgroup = GetBasketgroup( $$basket{basketgroupid} );
@ -436,17 +434,22 @@ sub GetBasketGroupAsCSV {
basketdeliveryplace => $basket->{deliveryplace},
basketbillingplace => $basket->{billingplace},
};
for my $place (qw( basketgroupdeliveryplace basketgroupbillingplace basketdeliveryplace basketbillingplace )) {
for my $place (
qw( basketgroupdeliveryplace basketgroupbillingplace basketdeliveryplace basketbillingplace ))
{
if ( my $library = Koha::Libraries->find( $temp->{$place} ) ) {
$row->{$place} = $library->branchname;
}
}
foreach(qw(
foreach (
qw(
basketname author title publishercode collectiontitle notes
booksellername bookselleraddress booksellerpostal contractname
basketgroupdeliveryplace basketgroupbillingplace
basketdeliveryplace basketbillingplace
) ) {
)
)
{
# Double the quotes to not be interpreted as a field end
$row->{$_} =~ s/"/""/g if $row->{$_};
}
@ -525,6 +528,7 @@ sub ModBasket {
push( @params, $basketinfo->{$key} || undef );
}
}
# get rid of the "," at the end of $query
if ( substr( $query, length($query) - 2 ) eq ', ' ) {
chop($query);
@ -539,9 +543,7 @@ sub ModBasket {
# Log the basket update
if ( C4::Context->preference("AcquisitionLog") ) {
my $modified = Koha::Acquisition::Baskets->find(
$basketinfo->{basketno}
);
my $modified = Koha::Acquisition::Baskets->find( $basketinfo->{basketno} );
logaction(
'ACQUISITIONS',
'MODIFY_BASKET',
@ -589,7 +591,10 @@ case the AcqCreateItem syspref takes precedence).
=cut
sub ModBasketHeader {
my ($basketno, $basketname, $note, $booksellernote, $contractnumber, $booksellerid, $deliveryplace, $billingplace, $is_standing, $create_items) = @_;
my (
$basketno, $basketname, $note, $booksellernote, $contractnumber, $booksellerid, $deliveryplace, $billingplace,
$is_standing, $create_items
) = @_;
$is_standing ||= 0;
my $query = qq{
@ -600,7 +605,10 @@ sub ModBasketHeader {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare($query);
$sth->execute($basketname, $note, $booksellernote, $booksellerid, $deliveryplace, $billingplace, $is_standing, $create_items || undef, $basketno);
$sth->execute(
$basketname, $note, $booksellernote, $booksellerid, $deliveryplace, $billingplace, $is_standing,
$create_items || undef, $basketno
);
if ($contractnumber) {
my $query2 = "UPDATE aqbasket SET contractnumber=? WHERE basketno=?";
@ -610,9 +618,7 @@ sub ModBasketHeader {
# Log the basket update
if ( C4::Context->preference("AcquisitionLog") ) {
my $modified = Koha::Acquisition::Baskets->find(
$basketno
);
my $modified = Koha::Acquisition::Baskets->find($basketno);
logaction(
'ACQUISITIONS',
'MODIFY_BASKET_HEADER',
@ -706,9 +712,11 @@ sub GetBasketsInfosByBookseller {
LEFT JOIN aqorders ON aqorders.basketno = aqbasket.basketno
WHERE booksellerid = ?};
$query.=" GROUP BY aqbasket.basketno, aqbasket.basketname, aqbasket.note, aqbasket.booksellernote, aqbasket.contractnumber, aqbasket.creationdate, aqbasket.closedate, aqbasket.booksellerid, aqbasket.authorisedby, aqbasket.booksellerinvoicenumber, aqbasket.basketgroupid, aqbasket.deliveryplace, aqbasket.billingplace, aqbasket.branch, aqbasket.is_standing, aqbasket.create_items";
$query .=
" GROUP BY aqbasket.basketno, aqbasket.basketname, aqbasket.note, aqbasket.booksellernote, aqbasket.contractnumber, aqbasket.creationdate, aqbasket.closedate, aqbasket.booksellerid, aqbasket.authorisedby, aqbasket.booksellerinvoicenumber, aqbasket.basketgroupid, aqbasket.deliveryplace, aqbasket.billingplace, aqbasket.branch, aqbasket.is_standing, aqbasket.create_items";
unless ($allbaskets) {
# Don't show the basket if it's NOT CLOSED or is FULLY RECEIVED
$query .= " HAVING (closedate IS NULL OR (
SUM(
@ -724,17 +732,18 @@ sub GetBasketsInfosByBookseller {
my $baskets = $sth->fetchall_arrayref( {} );
# Retrieve the number of biblios cancelled
my $cancelled_biblios = $dbh->selectall_hashref( q|
my $cancelled_biblios = $dbh->selectall_hashref(
q|
SELECT COUNT(DISTINCT(biblionumber)) AS total_biblios_cancelled, aqbasket.basketno
FROM aqbasket
LEFT JOIN aqorders ON aqorders.basketno = aqbasket.basketno
WHERE booksellerid = ?
AND aqorders.orderstatus = 'cancelled'
GROUP BY aqbasket.basketno
|, 'basketno', {}, $supplierid );
map {
$_->{total_biblios_cancelled} = $cancelled_biblios->{$_->{basketno}}{total_biblios_cancelled} || 0
} @$baskets;
|, 'basketno', {}, $supplierid
);
map { $_->{total_biblios_cancelled} = $cancelled_biblios->{ $_->{basketno} }{total_biblios_cancelled} || 0 }
@$baskets;
return $baskets;
}
@ -808,10 +817,12 @@ sub ModBasketUsers {
'ACQUISITIONS',
'MODIFY_BASKET_USERS',
$basketno,
to_json({
to_json(
{
basketno => $basketno,
basketusers => @basketusers_ids
})
}
)
);
}
@ -845,6 +856,7 @@ sub CanUserManageBasket {
my ( $borrower, $basket, $userflags ) = @_;
if ( !ref $borrower ) {
# FIXME This needs to be replaced
# We should not accept both scalar and array
# Tests need to be updated
@ -880,18 +892,22 @@ sub CanUserManageBasket {
}
if ( ( ref $userflags->{acquisition} && !$userflags->{acquisition}->{order_manage} )
|| (!ref $userflags->{acquisition} && !$userflags->{acquisition}) ) {
|| ( !ref $userflags->{acquisition} && !$userflags->{acquisition} ) )
{
return 0;
}
if ( $AcqViewBaskets eq 'user'
&& $basket->{authorisedby} != $borrowernumber
&& ! grep { $borrowernumber eq $_ } GetBasketUsers($basketno)) {
&& !grep { $borrowernumber eq $_ } GetBasketUsers($basketno) )
{
return 0;
}
if ($AcqViewBaskets eq 'branch' && defined $basket->{branch}
&& $basket->{branch} ne $borrower->{branchcode}) {
if ( $AcqViewBaskets eq 'branch'
&& defined $basket->{branch}
&& $basket->{branch} ne $borrower->{branchcode} )
{
return 0;
}
}
@ -1064,7 +1080,6 @@ sub DelBasketgroup {
#------------------------------------------------------------#
=head2 FUNCTIONS ABOUT ORDERS
=head3 GetBasketgroup
@ -1168,10 +1183,8 @@ sub GetOrders {
$query .= q|
AND datecancellationprinted IS NOT NULL
|;
}
else {
$orderby ||=
q|aqorders.datecancellationprinted desc, aqorders.timestamp desc|;
} else {
$orderby ||= q|aqorders.datecancellationprinted desc, aqorders.timestamp desc|;
$query .= q|
AND datecancellationprinted IS NULL
|;
@ -1302,12 +1315,14 @@ sub ModOrder {
my $sth = $dbh->prepare("SELECT * FROM aqorders LIMIT 1;");
$sth->execute;
my $colnames = $sth->{NAME};
#FIXME Be careful. If aqorders would have columns with diacritics,
#you should need to decode what you get back from NAME.
#See report 10110 and guided_reports.pl
my $query = "UPDATE aqorders SET ";
foreach my $orderinfokey ( grep( !/ordernumber/, keys %$orderinfo ) ) {
# ... and skip hash entries that are not in the aqorders table
# FIXME : probably not the best way to do it (would be better to have a correct hash)
next unless grep { $_ eq $orderinfokey } @$colnames;
@ -1374,7 +1389,6 @@ C<$order->{ordernumber}>.
=cut
sub ModReceiveOrder {
my ($params) = @_;
my $biblionumber = $params->{biblionumber};
@ -1395,20 +1409,25 @@ sub ModReceiveOrder {
my $suggestionid = GetSuggestionFromBiblionumber($biblionumber);
if ($suggestionid) {
ModSuggestion( {suggestionid=>$suggestionid,
ModSuggestion(
{
suggestionid => $suggestionid,
STATUS => 'AVAILABLE',
biblionumber=> $biblionumber}
biblionumber => $biblionumber
}
);
}
my $result_set = $dbh->selectrow_arrayref(
q{SELECT aqbasket.is_standing
FROM aqbasket
WHERE basketno=?},{ Slice => {} }, $order->{basketno});
WHERE basketno=?}, { Slice => {} }, $order->{basketno}
);
my $is_standing = $result_set->[0]; # we assume we have a unique basket
my $new_ordernumber = $order->{ordernumber};
if ( $is_standing || $order->{quantity} > $quantrec ) {
# Split order line in two parts: the first is the original order line
# without received items (the quantity is decreased),
# the second part is a new order line with quantity=quantityrec
@ -1429,13 +1448,14 @@ sub ModReceiveOrder {
$query = q|
UPDATE aqorders
SET
tax_value_on_ordering = quantity * | . get_rounding_sql(q|ecost_tax_excluded|) . q| * tax_rate_on_ordering,
tax_value_on_receiving = quantity * | . get_rounding_sql(q|unitprice_tax_excluded|) . q| * tax_rate_on_receiving
tax_value_on_ordering = quantity * |
. get_rounding_sql(q|ecost_tax_excluded|) . q| * tax_rate_on_ordering,
tax_value_on_receiving = quantity * |
. get_rounding_sql(q|unitprice_tax_excluded|) . q| * tax_rate_on_receiving
|;
my @params;
if ( not $order->{subscriptionid} && defined $order->{order_internalnote} )
{
if ( not $order->{subscriptionid} && defined $order->{order_internalnote} ) {
$query .= q|, order_internalnote = ?|;
push @params, $order->{order_internalnote};
}
@ -1457,8 +1477,12 @@ sub ModReceiveOrder {
$order->{tax_rate_on_ordering} //= 0;
$order->{unitprice_tax_excluded} //= 0;
$order->{tax_rate_on_receiving} //= 0;
$order->{tax_value_on_ordering} = $order->{quantity} * get_rounded_price($order->{ecost_tax_excluded}) * $order->{tax_rate_on_ordering};
$order->{tax_value_on_receiving} = $order->{quantity} * get_rounded_price($order->{unitprice_tax_excluded}) * $order->{tax_rate_on_receiving};
$order->{tax_value_on_ordering} =
$order->{quantity} * get_rounded_price( $order->{ecost_tax_excluded} ) * $order->{tax_rate_on_ordering};
$order->{tax_value_on_receiving} =
$order->{quantity} *
get_rounded_price( $order->{unitprice_tax_excluded} ) *
$order->{tax_rate_on_receiving};
$order->{datereceived} = $datereceived;
$order->{invoiceid} = $invoice->{invoiceid};
$order->{orderstatus} = 'complete';
@ -1506,7 +1530,8 @@ sub ModReceiveOrder {
$query .= q| where biblionumber=? and ordernumber=?|;
my $sth = $dbh->prepare($query);
my @params = ( $quantrec, $datereceived, $invoice->{invoiceid}, ( $budget_id ? $budget_id : $order->{budget_id} ) );
my @params =
( $quantrec, $datereceived, $invoice->{invoiceid}, ( $budget_id ? $budget_id : $order->{budget_id} ) );
if ( defined $order->{replacementprice} ) {
push @params, $order->{replacementprice};
@ -1581,6 +1606,7 @@ sub CancelReceipt {
my @itemnumbers = $order_obj->items->get_column('itemnumber');
if ( $parent_ordernumber == $ordernumber || not $parent_ordernumber ) {
# The order line has no parent, just mark it as not received
$query = qq{
UPDATE aqorders
@ -1594,6 +1620,7 @@ sub CancelReceipt {
$sth->execute( 0, undef, undef, $ordernumber );
_cancel_items_receipt($order_obj);
} else {
# The order line has a parent, increase parent quantity and delete
# the order line.
unless ( $order_obj->basket->is_standing ) {
@ -1610,8 +1637,7 @@ sub CancelReceipt {
return;
}
if ( $parent_order->{'datereceived'} ) {
warn "CancelReceipt: parent order is received.".
" Can't cancel receipt.";
warn "CancelReceipt: parent order is received." . " Can't cancel receipt.";
return;
}
$query = qq{
@ -1626,22 +1652,26 @@ sub CancelReceipt {
$parent_ordernumber
);
unless ($rv) {
warn "Cannot update parent order line, so do not cancel".
" receipt";
warn "Cannot update parent order line, so do not cancel" . " receipt";
return;
}
# Recalculate tax_value
$dbh->do(q|
$dbh->do(
q|
UPDATE aqorders
SET
tax_value_on_ordering = quantity * | . get_rounding_sql(q|ecost_tax_excluded|) . q| * tax_rate_on_ordering,
tax_value_on_receiving = quantity * | . get_rounding_sql(q|unitprice_tax_excluded|) . q| * tax_rate_on_receiving
tax_value_on_ordering = quantity * |
. get_rounding_sql(q|ecost_tax_excluded|) . q| * tax_rate_on_ordering,
tax_value_on_receiving = quantity * |
. get_rounding_sql(q|unitprice_tax_excluded|) . q| * tax_rate_on_receiving
WHERE ordernumber = ?
|, undef, $parent_ordernumber);
|, undef, $parent_ordernumber
);
}
_cancel_items_receipt( $order_obj, $parent_ordernumber );
# Delete order line
$query = qq{
DELETE FROM aqorders
@ -1656,7 +1686,8 @@ sub CancelReceipt {
my @affects = split q{\|}, C4::Context->preference("AcqItemSetSubfieldsWhenReceiptIsCancelled");
if (@affects) {
for my $in (@itemnumbers) {
my $item = Koha::Items->find( $in ); # FIXME We do not need that, we already have Koha::Items from $order_obj->items
my $item = Koha::Items->find($in)
; # FIXME We do not need that, we already have Koha::Items from $order_obj->items
my $biblio = $item->biblio;
my ($itemfield) = GetMarcFromKohaField('items.itemnumber');
my $item_marc = C4::Items::GetMarcItem( $biblio->biblionumber, $in );
@ -1680,6 +1711,7 @@ sub _cancel_items_receipt {
my $items = $order->items;
if ( $order->basket->effective_create_items eq 'receiving' ) {
# Remove items that were created at receipt
my $query = qq{
DELETE FROM items, aqorders_items
@ -1692,6 +1724,7 @@ sub _cancel_items_receipt {
$sth->execute( $item->itemnumber, $item->itemnumber );
}
} else {
# Update items
while ( my $item = $items->next ) {
ModItemOrder( $item->itemnumber, $parent_ordernumber );
@ -1927,11 +1960,13 @@ sub TransferOrder {
# Copy additional fields values
foreach my $afv ( $order->additional_field_values->as_list ) {
Koha::AdditionalFieldValue->new({
Koha::AdditionalFieldValue->new(
{
field_id => $afv->field_id,
record_id => $newordernumber,
value => $afv->value,
})->store;
}
)->store;
}
return $newordernumber;
@ -2021,6 +2056,7 @@ returns:
=cut
sub GetHistory {
# don't run the query if there are no parameters (list would be too long for sure !)
croak "No search params" unless @_;
my %params = @_;
@ -2361,9 +2397,7 @@ sub GetInvoices {
return () unless @invoices;
$matching_invoice_ids_for_additional_fields = [ map {
$_->id
} @invoices ];
$matching_invoice_ids_for_additional_fields = [ map { $_->id } @invoices ];
}
my @columns = qw(invoicenumber booksellerid shipmentdate billingdate
@ -2429,7 +2463,8 @@ sub GetInvoices {
push @bind_args, $args{billingdateto};
}
if ( $args{isbneanissn} ) {
push @bind_strs, " (biblioitems.isbn LIKE CONCAT('%', ?, '%') OR biblioitems.ean LIKE CONCAT('%', ?, '%') OR biblioitems.issn LIKE CONCAT('%', ?, '%') ) ";
push @bind_strs,
" (biblioitems.isbn LIKE CONCAT('%', ?, '%') OR biblioitems.ean LIKE CONCAT('%', ?, '%') OR biblioitems.issn LIKE CONCAT('%', ?, '%') ) ";
push @bind_args, $args{isbneanissn}, $args{isbneanissn}, $args{isbneanissn};
}
if ( $args{title} ) {
@ -2445,7 +2480,8 @@ sub GetInvoices {
push @bind_args, $args{publisher};
}
if ( $args{publicationyear} ) {
push @bind_strs, " ((biblioitems.publicationyear LIKE CONCAT('%', ?, '%')) OR (biblio.copyrightdate LIKE CONCAT('%', ?, '%'))) ";
push @bind_strs,
" ((biblioitems.publicationyear LIKE CONCAT('%', ?, '%')) OR (biblio.copyrightdate LIKE CONCAT('%', ?, '%'))) ";
push @bind_args, $args{publicationyear}, $args{publicationyear};
}
if ( $args{branchcode} ) {
@ -2473,12 +2509,12 @@ sub GetInvoices {
if (@bind_strs) { # there's a WHERE already
$operator = ' AND';
}
$query .= "$operator aqinvoices.invoiceid IN ("
. join( ', ', @$matching_invoice_ids_for_additional_fields )
. ')';
$query .=
"$operator aqinvoices.invoiceid IN (" . join( ', ', @$matching_invoice_ids_for_additional_fields ) . ')';
}
$query .= " GROUP BY aqinvoices.invoiceid, aqinvoices.invoicenumber, aqinvoices.booksellerid, aqinvoices.shipmentdate, aqinvoices.billingdate, aqinvoices.closedate, aqinvoices.shipmentcost, aqinvoices.shipmentcost_budgetid, aqinvoices.message_id, aqbooksellers.name";
$query .=
" GROUP BY aqinvoices.invoiceid, aqinvoices.invoicenumber, aqinvoices.booksellerid, aqinvoices.shipmentdate, aqinvoices.billingdate, aqinvoices.closedate, aqinvoices.shipmentcost, aqinvoices.shipmentcost_budgetid, aqinvoices.message_id, aqbooksellers.name";
if ( $args{order_by} ) {
my ( $column, $direction ) = split / /, $args{order_by};
@ -2922,8 +2958,7 @@ sub FillWithDefaultValues {
my $mandatory = $params->{only_mandatory};
my $tagslib = C4::Biblio::GetMarcStructure( 1, 'ACQ', { unsafe => 1 } );
if ($tagslib) {
my ($itemfield) =
C4::Biblio::GetMarcFromKohaField( 'items.itemnumber' );
my ($itemfield) = C4::Biblio::GetMarcFromKohaField('items.itemnumber');
for my $tag ( sort keys %$tagslib ) {
next unless $tag;
next if $tag == $itemfield;
@ -2937,27 +2972,16 @@ sub FillWithDefaultValues {
for my $field (@fields) {
if ( $field->is_control_field ) {
$field->update($defaultvalue) if not defined $field->data;
}
elsif ( not defined $field->subfield($subfield) ) {
$field->add_subfields(
$subfield => $defaultvalue );
} elsif ( not defined $field->subfield($subfield) ) {
$field->add_subfields( $subfield => $defaultvalue );
}
}
}
else {
} else {
if ( $tag < 10 ) { # is_control_field
$record->insert_fields_ordered( MARC::Field->new( $tag, $defaultvalue ) );
} else {
$record->insert_fields_ordered(
MARC::Field->new(
$tag, $defaultvalue
)
);
}
else {
$record->insert_fields_ordered(
MARC::Field->new(
$tag, '', '', $subfield => $defaultvalue
)
);
MARC::Field->new( $tag, '', '', $subfield => $defaultvalue ) );
}
}
}

307
C4/Auth.pm
View File

@ -64,12 +64,12 @@ our (@ISA, @EXPORT_OK);
#NOTE: The utility of keeping the safe_exit function is that it can be easily re-defined in unit tests and plugins
sub safe_exit {
# It's fine for us to "exit" because CGI::Compile (used in Plack::App::WrapCGI) redefines "exit" for us automatically.
# Since we only seem to use C4::Auth::safe_exit in a CGI context, we don't actually need PSGI detection at all here.
exit;
}
BEGIN {
C4::Context->set_remote_address;
@ -87,7 +87,8 @@ BEGIN {
if ($cas) {
require C4::Auth_with_cas; # no import
import C4::Auth_with_cas qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required multipleAuth getMultipleAuth);
import C4::Auth_with_cas
qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required multipleAuth getMultipleAuth);
}
}
@ -210,15 +211,18 @@ sub get_template_and_user {
# If we enforce GDPR and the user did not consent, redirect
# Exceptions for consent page itself and SCI/SCO system
if( $in->{type} eq 'opac' && $user &&
$in->{'template_name'} !~ /^(opac-page|opac-patron-consent|sc[io]\/)/ &&
C4::Context->preference('PrivacyPolicyConsent') eq 'Enforced' )
if ( $in->{type} eq 'opac'
&& $user
&& $in->{'template_name'} !~ /^(opac-page|opac-patron-consent|sc[io]\/)/
&& C4::Context->preference('PrivacyPolicyConsent') eq 'Enforced' )
{
my $consent = Koha::Patron::Consents->search(
{
my $consent = Koha::Patron::Consents->search({
borrowernumber => getborrowernumber($user),
type => 'GDPR_PROCESSING',
given_on => { '!=', undef },
})->next;
}
)->next;
if ( !$consent ) {
print $in->{query}->redirect( -uri => '/cgi-bin/koha/opac-patron-consent.pl', -cookie => $cookie );
safe_exit;
@ -235,54 +239,59 @@ sub get_template_and_user {
if (
# If the user logged in is the SCO user and they try to go out of the SCO module,
# log the user out removing the CGISESSID cookie
$in->{template_name} !~ m|sco/| && $in->{template_name} !~ m|errors/errorpage.tt|
$in->{template_name} !~ m|sco/|
&& $in->{template_name} !~ m|errors/errorpage.tt|
&& (
$is_sco_user ||
(
C4::Context->preference('AutoSelfCheckID')
&& $user eq C4::Context->preference('AutoSelfCheckID')
)
$is_sco_user
|| ( C4::Context->preference('AutoSelfCheckID')
&& $user eq C4::Context->preference('AutoSelfCheckID') )
)
)
{
$kick_out = 1;
}
elsif (
} elsif (
# If the user logged in is the SCI user and they try to go out of the SCI module,
# kick them out unless it is SCO with a valid permission
# or they are a superlibrarian
$in->{template_name} !~ m|sci/| && $in->{template_name} !~ m|errors/errorpage.tt|
$in->{template_name} !~ m|sci/|
&& $in->{template_name} !~ m|errors/errorpage.tt|
&& haspermission( $user, { self_check => 'self_checkin_module' } )
&& !(
$in->{template_name} =~ m|sco/| && haspermission(
$user, { self_check => 'self_checkout_module' }
)
)
&& $flags && $flags->{superlibrarian} != 1
&& !( $in->{template_name} =~ m|sco/| && haspermission( $user, { self_check => 'self_checkout_module' } ) )
&& $flags
&& $flags->{superlibrarian} != 1
)
{
$kick_out = 1;
}
if ($kick_out) {
$template = C4::Templates::gettemplate( 'opac-auth.tt', 'opac',
$in->{query} );
$cookie = $cookie_mgr->replace_in_list( $cookie, $in->{query}->cookie(
$template = C4::Templates::gettemplate(
'opac-auth.tt', 'opac',
$in->{query}
);
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$in->{query}->cookie(
-name => 'CGISESSID',
-value => '',
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
#NOTE: This JWT should only be used by the self-check controllers
$cookie = $cookie_mgr->replace_in_list( $cookie, $in->{query}->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$in->{query}->cookie(
-name => 'JWT',
-value => '',
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
my $auth_error = $in->{query}->param('auth_error');
@ -324,6 +333,7 @@ sub get_template_and_user {
}
} else {
$patron = Koha::Patrons->find($borrowernumber);
# FIXME What to do if $patron does not exist?
}
@ -368,8 +378,8 @@ sub get_template_and_user {
# We show the link in opac
$template->param( EnableOpacSearchHistory => 1 );
}
if (C4::Context->preference('LoadSearchHistoryToTheFirstLoggedUser'))
{
if ( C4::Context->preference('LoadSearchHistoryToTheFirstLoggedUser') ) {
# And if there are searches performed when the user was not logged in,
# we add them to the logged-in search history
my @recentSearches = C4::Search::History::get_from_session( { cgi => $in->{'query'} } );
@ -379,7 +389,8 @@ sub get_template_and_user {
VALUES (?, ?, ?, ?, ?, ?, ?)
};
my $sth = $dbh->prepare($query);
$sth->execute( $borrowernumber,
$sth->execute(
$borrowernumber,
$in->{query}->cookie("CGISESSID"),
$_->{query_desc},
$_->{query_cgi},
@ -397,13 +408,13 @@ sub get_template_and_user {
} elsif ( $in->{type} eq 'intranet' and C4::Context->preference('EnableSearchHistory') ) {
$template->param( EnableSearchHistory => 1 );
}
}
else { # if this is an anonymous session, setup to display public lists...
} else { # if this is an anonymous session, setup to display public lists...
# If shibboleth is enabled, and we're in an anonymous session, we should allow
# the user to attempt login via shibboleth.
if ($shib) {
$template->param( shibbolethAuthentication => $shib,
$template->param(
shibbolethAuthentication => $shib,
shibbolethLoginUrl => login_shib_url( $in->{'query'} ),
);
@ -520,8 +531,7 @@ sub get_template_and_user {
useDischarge => C4::Context->preference('useDischarge'),
virtualshelves => C4::Context->preference("virtualshelves"),
);
}
else {
} else {
warn "template type should be OPAC, here it is=[" . $in->{'type'} . "]" unless ( $in->{'type'} eq 'opac' );
#TODO : replace LibraryName syspref with 'system name', and remove this html processing
@ -533,7 +543,8 @@ sub get_template_and_user {
# if the page is not opac-detail and not the "add to list" page
# and not the "edit comments" page
if ( C4::Context->preference("OpacBrowseResults")
&& $in->{'template_name'} =~ /opac-(.+)\.(?:tt|tmpl)$/ ) {
&& $in->{'template_name'} =~ /opac-(.+)\.(?:tt|tmpl)$/ )
{
my $pagename = $1;
unless ( $pagename =~ /^(?:MARC|ISBD)?detail$/
or $pagename =~ /^showmarc$/
@ -548,15 +559,17 @@ sub get_template_and_user {
my $opac_search_limit = $ENV{'OPAC_SEARCH_LIMIT'};
my $opac_limit_override = $ENV{'OPAC_LIMIT_OVERRIDE'};
my $opac_name = '';
if (
( $opac_limit_override && $opac_search_limit && $opac_search_limit =~ /^branch:([\w-]+)/ ) ||
( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /^branch:([\w-]+)/ ) ||
( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /^multibranchlimit:(\w+)/ )
) {
if ( ( $opac_limit_override && $opac_search_limit && $opac_search_limit =~ /^branch:([\w-]+)/ )
|| ( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /^branch:([\w-]+)/ )
|| ( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /^multibranchlimit:(\w+)/ ) )
{
$opac_name = $1; # opac_search_limit is a branch, so we use it.
} elsif ( $in->{'query'}->param('multibranchlimit') ) {
$opac_name = $in->{'query'}->param('multibranchlimit');
} elsif ( C4::Context->preference("SearchMyLibraryFirst") && C4::Context->userenv && C4::Context->userenv->{'branch'} ) {
} elsif ( C4::Context->preference("SearchMyLibraryFirst")
&& C4::Context->userenv
&& C4::Context->userenv->{'branch'} )
{
$opac_name = C4::Context->userenv->{'branch'};
}
@ -565,7 +578,8 @@ sub get_template_and_user {
if ( C4::Context->preference('Suggestion') && C4::Context->preference('AnonSuggestions') ) {
$can_make_suggestions = 1;
} elsif ( C4::Context->userenv && C4::Context->userenv->{'number'} ) {
$can_make_suggestions = Koha::Patrons->find(C4::Context->userenv->{'number'})->category->can_make_suggestions;
$can_make_suggestions =
Koha::Patrons->find( C4::Context->userenv->{'number'} )->category->can_make_suggestions;
}
my @search_groups = Koha::Library::Groups->get_search_groups( { interface => 'opac' } )->as_list;
@ -594,7 +608,9 @@ sub get_template_and_user {
OpacTopissue => C4::Context->preference("OpacTopissue"),
'Version' => C4::Context->preference('Version'),
hidelostitems => C4::Context->preference("hidelostitems"),
mylibraryfirst => ( C4::Context->preference("SearchMyLibraryFirst") && C4::Context->userenv ) ? C4::Context->userenv->{'branch'} : '',
mylibraryfirst => ( C4::Context->preference("SearchMyLibraryFirst") && C4::Context->userenv )
? C4::Context->userenv->{'branch'}
: '',
opacbookbag => "" . C4::Context->preference("opacbookbag"),
OpacFavicon => C4::Context->preference("OpacFavicon"),
opaclanguagesdisplay => "" . C4::Context->preference("opaclanguagesdisplay"),
@ -638,8 +654,10 @@ sub get_template_and_user {
}
# user info
$template->param( loggedinusername => $user ); # OBSOLETE - Do not reuse this in template, use logged_in_user.userid instead
$template->param( loggedinusernumber => $borrowernumber ); # FIXME Should be replaced with logged_in_user.borrowernumber
$template->param( loggedinusername => $user )
; # OBSOLETE - Do not reuse this in template, use logged_in_user.userid instead
$template->param( loggedinusernumber => $borrowernumber )
; # FIXME Should be replaced with logged_in_user.borrowernumber
$template->param( logged_in_user => $patron );
$template->param( sessionID => $sessionID );
@ -778,11 +796,11 @@ sub _timeout_syspref {
if ( $timeout =~ /^(\d+)[dD]$/ ) {
$timeout = $1 * 86400;
}
# value in hours, convert in seconds
elsif ( $timeout =~ /^(\d+)[hH]$/ ) {
$timeout = $1 * 3600;
}
elsif ( $timeout !~ m/^\d+$/ ) {
} elsif ( $timeout !~ m/^\d+$/ ) {
warn "The value of the system preference 'timeout' is not correct, defaulting to $default_timeout";
$timeout = $default_timeout;
}
@ -818,8 +836,7 @@ sub checkauth {
opac-reset-password.tt
ilsdi.tt
);
$authnotrequired = 0 unless grep { $_ eq $template_name }
@allowed_scripts_for_private_opac;
$authnotrequired = 0 unless grep { $_ eq $template_name } @allowed_scripts_for_private_opac;
}
my $timeout = _timeout_syspref();
@ -837,6 +854,7 @@ sub checkauth {
my $anon_search_history;
my $cas_ticket = '';
# This parameter is the name of the CAS server we want to authenticate against,
# when using authentication against multiple CAS servers, as configured in Auth_cas_servers.yaml
my $casparam = $query->param('cas');
@ -844,9 +862,10 @@ sub checkauth {
my $session;
my $invalid_otp_token;
my $require_2FA =
( $type ne "opac" # Only available for the staff interface
&& C4::Context->preference('TwoFactorAuthentication') ne "disabled" ) # If "enabled" or "enforced"
my $require_2FA = (
$type ne "opac" # Only available for the staff interface
&& C4::Context->preference('TwoFactorAuthentication') ne "disabled"
) # If "enabled" or "enforced"
? 1 : 0;
# Basic authentication is incompatible with the use of Shibboleth,
@ -861,21 +880,25 @@ sub checkauth {
if ( !$shib and defined( $ENV{'REMOTE_USER'} ) and $ENV{'REMOTE_USER'} ne '' and $userid = $ENV{'REMOTE_USER'} ) {
# Using Basic Authentication, no cookies required
$cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$query->cookie(
-name => 'CGISESSID',
-value => '',
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
}
elsif ( $emailaddress) {
)
);
} elsif ($emailaddress) {
# the Google OpenID Connect passes an email address
}
elsif ( $sessionID = $query->cookie("CGISESSID") ) { # assignment, not comparison
} elsif ( $sessionID = $query->cookie("CGISESSID") ) { # assignment, not comparison
my ( $return, $more_info );
# NOTE: $flags in the following call is still undefined !
( $return, $session, $more_info ) = check_cookie_auth( $sessionID, $flags,
( $return, $session, $more_info ) = check_cookie_auth(
$sessionID, $flags,
{ remote_addr => $ENV{REMOTE_ADDR}, skip_version_check => 1 }
);
@ -899,6 +922,7 @@ sub checkauth {
my $verified = $auth->verify($otp_token);
$auth->clear;
if ($verified) {
# The token is correct, the user is fully logged in!
$auth_state = 'completed';
$session->param( 'waiting-for-2FA', 0 );
@ -908,19 +932,21 @@ sub checkauth {
# $query->param('koha_login_context') && ( $q_userid ne $userid )
# few lines later
$q_userid = $userid;
}
else {
} else {
$invalid_otp_token = 1;
}
}
if ( $auth_state eq 'completed' ) {
Koha::Logger->get->debug(sprintf "AUTH_SESSION: (%s)\t%s %s - %s", map { $session->param($_) || q{} } qw(cardnumber firstname surname branch));
Koha::Logger->get->debug(
sprintf "AUTH_SESSION: (%s)\t%s %s - %s",
map { $session->param($_) || q{} } qw(cardnumber firstname surname branch)
);
if ( ( $query->param('koha_login_context') && ( $q_userid ne $userid ) )
|| ( $cas && $query->param('ticket') && !C4::Context->userenv->{'id'} )
|| ( $shib && $shib_login && !$logout && !C4::Context->userenv->{'id'} )
) {
|| ( $shib && $shib_login && !$logout && !C4::Context->userenv->{'id'} ) )
{
#if a user enters an id ne to the id in the current session, we need to log them in...
#first we need to clear the anonymous session...
@ -934,13 +960,16 @@ sub checkauth {
$auth_state = 'failed';
} elsif ( !$logout ) {
$cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$query->cookie(
-name => 'CGISESSID',
-value => $session->id,
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
$flags = haspermission( $userid, $flagsrequired );
unless ($flags) {
@ -994,6 +1023,7 @@ sub checkauth {
}
unless ($userid) {
#we initiate a session prior to checking for a username to allow for anonymous sessions...
if ( !$session or !$sessionID ) { # if we cleared sessionID, we need a new session
$session = get_session() or die "Auth ERROR: Cannot get_session()";
@ -1007,13 +1037,16 @@ sub checkauth {
}
$sessionID = $session->id;
$cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$query->cookie(
-name => 'CGISESSID',
-value => $sessionID,
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
my $pki_field = C4::Context->preference('AllowPKIAuth');
if ( !defined($pki_field) ) {
print STDERR "ERROR: Missing system preference AllowPKIAuth.\n";
@ -1049,9 +1082,8 @@ sub checkauth {
checkpw( $userid, $password, $query, $type );
$userid = $retuserid;
$info{'invalidCasLogin'} = 1 unless ($return);
}
elsif ( $emailaddress ) {
} elsif ($emailaddress) {
my $value = $emailaddress;
# If we're looking up the email, there's a chance that the person
@ -1069,9 +1101,8 @@ sub checkauth {
}
$return = $value ? 1 : 0;
$userid = $value;
}
elsif (
} elsif (
( $pki_field eq 'Common Name' && $ENV{'SSL_CLIENT_S_DN_CN'} )
|| ( $pki_field eq 'emailAddress'
&& $ENV{'SSL_CLIENT_S_DN_Email'} )
@ -1080,8 +1111,7 @@ sub checkauth {
my $value;
if ( $pki_field eq 'Common Name' ) {
$value = $ENV{'SSL_CLIENT_S_DN_CN'};
}
elsif ( $pki_field eq 'emailAddress' ) {
} elsif ( $pki_field eq 'emailAddress' ) {
$value = $ENV{'SSL_CLIENT_S_DN_Email'};
# If we're looking up the email, there's a chance that the person
@ -1102,8 +1132,7 @@ sub checkauth {
$return = $value ? 1 : 0;
$userid = $value;
}
else {
} else {
my $retuserid;
if (
@ -1127,10 +1156,7 @@ sub checkauth {
$shib
&& !$shibSuccess
&& (
(
( $type eq 'opac' )
&& C4::Context->preference('OPACShibOnly')
)
( ( $type eq 'opac' ) && C4::Context->preference('OPACShibOnly') )
|| ( ( $type ne 'opac' )
&& C4::Context->preference('staffShibOnly') )
)
@ -1144,9 +1170,9 @@ sub checkauth {
if ( $flags = haspermission( $userid, $flagsrequired ) ) {
$auth_state = "logged_in";
}
else {
} else {
$auth_state = 'failed';
# FIXME We could add $return = 0; or even delete the session?
# Currently return == 1 and we will fill session info later on,
# although we do present an authorization failure. (Yes, the
@ -1154,9 +1180,11 @@ sub checkauth {
$info{'nopermission'} = 1;
C4::Context::unset_userenv();
}
my ( $borrowernumber, $firstname, $surname, $userflags,
my (
$borrowernumber, $firstname, $surname, $userflags,
$branchcode, $branchname, $emailaddress, $desk_id,
$desk_name, $register_id, $register_name );
$desk_name, $register_id, $register_name
);
if ( $return == 1 ) {
my $select = "
@ -1177,8 +1205,10 @@ sub checkauth {
}
}
if ( $sth->rows ) {
( $borrowernumber, $firstname, $surname, $userflags,
$branchcode, $branchname, $emailaddress ) = $sth->fetchrow;
(
$borrowernumber, $firstname, $surname, $userflags,
$branchcode, $branchname, $emailaddress
) = $sth->fetchrow;
}
# launch a sequence to check if we have a ip for the branch, i
@ -1188,7 +1218,9 @@ sub checkauth {
# if they specify at login, use that
my $patron = Koha::Patrons->find( { userid => $userid } );
if ( $query->param('branch') && ( haspermission($userid, { 'loggedinlibrary'=> 1 }) || $patron->is_superlibrarian ) ) {
if ( $query->param('branch')
&& ( haspermission( $userid, { 'loggedinlibrary' => 1 } ) || $patron->is_superlibrarian ) )
{
$branchcode = $query->param('branch');
my $library = Koha::Libraries->find($branchcode);
$branchname = $library ? $library->branchname : '';
@ -1204,25 +1236,30 @@ sub checkauth {
? Koha::Cash::Registers->find( $query->param('register_id') )
: Koha::Cash::Registers->search(
{ branch => $branchcode, branch_default => 1 },
{ rows => 1 } )->single;
{ rows => 1 }
)->single;
$register_id = $register->id if ($register);
$register_name = $register->name if ($register);
}
if ( $type ne 'opac' ) {
my $branches = { map { $_->branchcode => $_->unblessed } Koha::Libraries->search->as_list };
if ( C4::Context->preference('StaffLoginRestrictLibraryByIP') ) {
# we have to check they are coming from the right ip range
my $domain = $branches->{$branchcode}->{'branchip'} // q{};
$domain =~ s|\.\*||g;
$domain =~ s/\s+//g;
if ( $domain && $ip !~ /^$domain/ ) {
$cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$query->cookie(
-name => 'CGISESSID',
-value => '',
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
$info{'wrongip'} = 1;
$auth_state = "failed";
}
@ -1295,6 +1332,7 @@ sub checkauth {
);
}
# $return: 0 = invalid user
# reset to anonymous session
else {
@ -1321,18 +1359,20 @@ sub checkauth {
$session->flush;
} # END unless ($userid)
if ( $auth_state eq 'logged_in' ) {
$auth_state = 'completed';
# Auth is completed unless an additional auth is needed
if ($require_2FA) {
my $patron = Koha::Patrons->find( { userid => $userid } );
if ( C4::Context->preference('TwoFactorAuthentication') eq "enforced" && $patron->auth_method eq 'password' ) {
if ( C4::Context->preference('TwoFactorAuthentication') eq "enforced"
&& $patron->auth_method eq 'password' )
{
$auth_state = 'setup-additional-auth-needed';
$session->param( 'waiting-for-2FA-setup', 1 );
%info = (); # We remove the warnings/errors we may have set incorrectly before
} elsif ( $patron->auth_method eq 'two-factor' ) {
# Ask for the OTP token
$auth_state = 'additional-auth-needed';
$session->param( 'waiting-for-2FA', 1 );
@ -1343,15 +1383,19 @@ sub checkauth {
# finished authentification, now respond
if ( $auth_state eq 'completed' || $authnotrequired ) {
# successful login
unless (@$cookie) {
$cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
$cookie = $cookie_mgr->replace_in_list(
$cookie,
$query->cookie(
-name => 'CGISESSID',
-value => '',
-HttpOnly => 1,
-secure => ( C4::Context->https_enabled() ? 1 : 0 ),
-sameSite => 'Lax',
));
)
);
}
my $patron = $userid ? Koha::Patrons->find( { userid => $userid } ) : undef;
@ -1364,7 +1408,6 @@ sub checkauth {
if $request_method eq 'GET';
}
if ( !$skip_csrf_check && $query->param('invalid_csrf_token') ) {
Koha::Exceptions::Token::WrongCSRFToken->throw;
}
@ -1372,7 +1415,12 @@ sub checkauth {
# In case, that this request was a login attempt, we want to prevent that users can repost the opac login
# request. We therefore redirect the user to the requested page again without the login parameters.
# See Post/Redirect/Get (PRG) design pattern: https://en.wikipedia.org/wiki/Post/Redirect/Get
if ( $type eq "opac" && $query->param('koha_login_context') && $query->param('koha_login_context') ne 'sco' && $query->param('login_password') && $query->param('login_userid') ) {
if ( $type eq "opac"
&& $query->param('koha_login_context')
&& $query->param('koha_login_context') ne 'sco'
&& $query->param('login_password')
&& $query->param('login_userid') )
{
my $uri = URI->new( $query->url( -relative => 1, -query_string => 1 ) );
$uri->query_param_delete('login_userid');
$uri->query_param_delete('login_password');
@ -1498,23 +1546,22 @@ sub checkauth {
foreach my $key ( keys %$casservers ) {
push @tmplservers, { name => $key, value => login_cas_url( $query, $key, $type ) . "?cas=$key" };
}
$template->param(
casServersLoop => \@tmplservers
);
$template->param( casServersLoop => \@tmplservers );
} else {
$template->param(
casServerUrl => login_cas_url( $query, undef, $type ),
);
}
$template->param(
invalidCasLogin => $info{'invalidCasLogin'}
);
$template->param( invalidCasLogin => $info{'invalidCasLogin'} );
}
if ($shib) {
#If shibOnly is enabled just go ahead and redirect directly
if ( (($type eq 'opac') && C4::Context->preference('OPACShibOnly')) || (($type ne 'opac') && C4::Context->preference('staffShibOnly')) ) {
if ( ( ( $type eq 'opac' ) && C4::Context->preference('OPACShibOnly') )
|| ( ( $type ne 'opac' ) && C4::Context->preference('staffShibOnly') ) )
{
my $redirect_url = login_shib_url($query);
print $query->redirect( -uri => "$redirect_url", -status => 303 );
safe_exit;
@ -1540,12 +1587,14 @@ sub checkauth {
);
if ( $params->{do_not_print} ) {
# This must be used for testing purpose only!
return ( undef, undef, undef, undef, $template );
}
print $query->header(
{ type => 'text/html',
{
type => 'text/html',
charset => 'utf-8',
cookie => $cookie,
'X-Frame-Options' => 'SAMEORIGIN',
@ -1622,8 +1671,8 @@ sub check_api_auth {
if ( $sessionID && not( $cas && $query->param('PT') ) ) {
my $return;
( $return, $session, undef ) = check_cookie_auth(
$sessionID, $flagsrequired, { remote_addr => $ENV{REMOTE_ADDR} } );
( $return, $session, undef ) =
check_cookie_auth( $sessionID, $flagsrequired, { remote_addr => $ENV{REMOTE_ADDR} } );
return ( $return, undef, undef ) # Cookie auth failed
if $return ne "ok";
@ -1692,7 +1741,9 @@ sub check_api_auth {
$borrowernumber, $firstname, $surname,
$userflags, $branchcode, $branchname,
$emailaddress
) = $sth->fetchrow if ( $sth->rows );
)
= $sth->fetchrow
if ( $sth->rows );
unless ( $sth->rows ) {
my $sth = $dbh->prepare(
@ -1703,14 +1754,18 @@ sub check_api_auth {
$borrowernumber, $firstname, $surname,
$userflags, $branchcode, $branchname,
$emailaddress
) = $sth->fetchrow if ( $sth->rows );
)
= $sth->fetchrow
if ( $sth->rows );
unless ( $sth->rows ) {
$sth->execute($userid);
(
$borrowernumber, $firstname, $surname, $userflags,
$branchcode, $branchname, $emailaddress
) = $sth->fetchrow if ( $sth->rows );
)
= $sth->fetchrow
if ( $sth->rows );
}
}
@ -1841,12 +1896,14 @@ sub check_cookie_auth {
my $timeout = _timeout_syspref();
if ( !$lasttime || ( $lasttime < time() - $timeout ) ) {
# time out
$session->delete();
$session->flush;
return ( "expired", undef );
} elsif ( C4::Context->preference('SessionRestrictionByIP') && $ip ne $remote_addr ) {
# IP address changed
$session->delete();
$session->flush;
@ -1870,6 +1927,7 @@ sub check_cookie_auth {
my $flags = defined($flagsrequired) ? haspermission( $userid, $flagsrequired ) : 1;
if ($flags) {
if ( !C4::Context->interface ) {
# No need to override the interface, most often set by get_template_and_user
C4::Context->interface( $session->param('interface') );
}
@ -1967,7 +2025,6 @@ sub create_basic_session {
return $session;
}
# FIXME no_set_userenv may be replaced with force_branchcode_for_userenv
# (or something similar)
# Currently it's only passed from C4::SIP::ILS::Patron::check_password, but
@ -2157,8 +2214,7 @@ sub getuserflags {
while ( my ( $bit, $flag, $defaulton ) = $sth->fetchrow ) {
if ( ( $flags & ( 2**$bit ) ) || $defaulton ) {
$userflags->{$flag} = 1;
}
else {
} else {
$userflags->{$flag} = 0;
}
}
@ -2202,12 +2258,14 @@ sub get_user_subpermissions {
my $userid = shift;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare( "SELECT flag, user_permissions.code
my $sth = $dbh->prepare(
"SELECT flag, user_permissions.code
FROM user_permissions
JOIN permissions USING (module_bit, code)
JOIN userflags ON (module_bit = bit)
JOIN borrowers USING (borrowernumber)
WHERE userid = ?" );
WHERE userid = ?"
);
$sth->execute($userid);
my $user_perms = {};
@ -2231,9 +2289,11 @@ of the subpermission.
sub get_all_subpermissions {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare( "SELECT flag, code
my $sth = $dbh->prepare(
"SELECT flag, code
FROM permissions
JOIN userflags ON (module_bit = bit)" );
JOIN userflags ON (module_bit = bit)"
);
$sth->execute();
my $all_perms = {};
@ -2330,7 +2390,7 @@ sub _dispatch {
}
return $flags;
};
}
sub haspermission {
my ( $userid, $flagsrequired ) = @_;
@ -2366,8 +2426,10 @@ sub in_iprange {
my @allowedipranges = $iprange ? split( ' ', $iprange ) : ();
if ( scalar @allowedipranges > 0 ) {
my @rangelist;
eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); }; return 0 if $@;
eval { $result = Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @rangelist) } || Koha::Logger->get->warn('cidrlookup failed for ' . join(' ',@rangelist) );
eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); };
return 0 if $@;
eval { $result = Net::CIDR::cidrlookup( $ENV{'REMOTE_ADDR'}, @rangelist ) }
|| Koha::Logger->get->warn( 'cidrlookup failed for ' . join( ' ', @rangelist ) );
}
return $result ? 1 : 0;
}
@ -2380,8 +2442,7 @@ sub getborrowernumber {
}
my $dbh = C4::Context->dbh;
for my $field ( 'userid', 'cardnumber' ) {
my $sth =
$dbh->prepare("select borrowernumber from borrowers where $field=?");
my $sth = $dbh->prepare("select borrowernumber from borrowers where $field=?");
$sth->execute($userid);
if ( $sth->rows ) {
my ($bnumber) = $sth->fetchrow;

9
C4/Auth_with_cas.pm
View File

@ -34,18 +34,19 @@ our (@ISA, @EXPORT_OK);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required multipleAuth getMultipleAuth);
@EXPORT_OK =
qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required multipleAuth getMultipleAuth);
}
my $defaultcasserver;
my $casservers;
my $yamlauthfile = C4::Context->config('intranetdir') . "/C4/Auth_cas_servers.yaml";
# If there's a configuration for multiple cas servers, then we get it
if ( multipleAuth() ) {
( $defaultcasserver, $casservers ) = YAML::XS::LoadFile($yamlauthfile);
$defaultcasserver = $defaultcasserver->{'default'};
} else {
# Else, we fall back to casServerUrl syspref
$defaultcasserver = 'default';
$casservers = { 'default' => C4::Context->preference('casServerUrl') };
@ -81,7 +82,6 @@ sub logout_cas {
print $query->redirect($logout_url);
}
# Login to CAS
sub login_cas {
my ( $query, $type ) = @_;
@ -217,6 +217,7 @@ sub _url_with_get_params {
my $uri_params_part = '';
foreach my $param ( $query->url_param() ) {
# url_param() always returns parameters that were deleted by delete()
# This additional check ensure that parameter was not deleted.
my $uriPiece = $query->param($param);
@ -239,6 +240,7 @@ sub _url_with_get_params {
sub logout_if_required {
my ($query) = @_;
# Check we havent been hit by a logout call
my $xml = $query->param('logoutRequest');
return 0 unless $xml;
@ -246,6 +248,7 @@ sub logout_if_required {
my $dom = XML::LibXML->load_xml( string => $xml );
my $ticket;
foreach my $node ( $dom->findnodes('/samlp:LogoutRequest') ) {
# We got a cas single logout request from a cas server;
$ticket = $node->findvalue('./samlp:SessionIndex');
}

85
C4/Auth_with_ldap.pm
View File

@ -30,6 +30,7 @@ use Net::LDAP;
use Net::LDAP::Filter;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -49,6 +50,7 @@ sub ldapserver_error {
use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
# since Bug 28278 we need to skip id in <ldapserver id="ldapserver"> which generates additional hash level
if ( exists $ldap->{ldapserver} ) {
$ldap = $ldap->{ldapserver} or die ldapserver_error('id="ldapserver"');
@ -57,10 +59,13 @@ my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
my $base = $ldap->{base} or die ldapserver_error('base');
$ldapname = $ldap->{user};
$ldappassword = $ldap->{pass};
our %mapping = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
our %mapping =
%{ $ldap->{mapping} }; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
my @mapkeys = keys %mapping;
#warn "Got ", scalar(@mapkeys), " ldap mapkeys ( total ): ", join ' ', @mapkeys, "\n";
@mapkeys = grep { defined $mapping{$_}->{is} } @mapkeys;
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
my %categorycode_conversions;
@ -74,16 +79,18 @@ if(defined $ldap->{categorycode_mapping}) {
my %config = (
anonymous => defined( $ldap->{anonymous_bind} ) ? $ldap->{anonymous_bind} : 1,
replicate => defined($ldap->{replicate}) ? $ldap->{replicate} : 1, # add from LDAP to Koha database for new user
welcome => defined($ldap->{welcome}) ? $ldap->{welcome} : 0, # send welcome notice when patron is added via replicate
replicate => defined( $ldap->{replicate} )
? $ldap->{replicate}
: 1, # add from LDAP to Koha database for new user
welcome => defined( $ldap->{welcome} )
? $ldap->{welcome}
: 0, # send welcome notice when patron is added via replicate
update => defined( $ldap->{update} ) ? $ldap->{update} : 1, # update from LDAP to Koha database for existing user
);
sub description {
my $result = shift or return;
return "LDAP error #" . $result->code
. ": " . $result->error_name . "\n"
. "# " . $result->error_text . "\n";
return "LDAP error #" . $result->code . ": " . $result->error_name . "\n" . "# " . $result->error_text . "\n";
}
sub search_method {
@ -94,6 +101,7 @@ sub search_method {
my $search = $db->search(
base => $base,
filter => $filter,
# attrs => ['*'],
);
die "LDAP search failed to return object : " . $search->error if $search->code;
@ -138,13 +146,11 @@ sub checkpw_ldap {
or return 0; # warnings are in the sub
$userldapentry = $search->shift_entry;
$principal_name = $userldapentry->dn;
}
else {
} else {
$principal_name = $ldap->{principal_name};
if ( $principal_name and $principal_name =~ /\%/ ) {
$principal_name = sprintf( $principal_name, $userid );
}
else {
} else {
$principal_name = $userid;
}
}
@ -153,12 +159,14 @@ sub checkpw_ldap {
my $res = $db->bind( $principal_name, password => $password );
if ( $res->code ) {
if ( $config{anonymous} ) {
# With anonymous_bind approach we can be sure we have found the correct user
# and that any 'code' response indicates a 'bad' user (be that blocked, banned
# or password changed). We should not fall back to local accounts in this case.
warn "LDAP bind failed as kohauser $userid: " . description($res);
return -1;
} else {
# Without a anonymous_bind, we cannot be sure we are looking at a valid ldap user
# at all, and thus we should fall back to local logins to restore previous behaviour
# see bug 12831
@ -195,7 +203,6 @@ sub checkpw_ldap {
return -1;
}
}
# To get here, LDAP has accepted our user's login attempt.
@ -205,9 +212,11 @@ sub checkpw_ldap {
my ( $borrowernumber, $cardnumber, $local_userid, $savedpw ) = exists_local($userid);
my $patron;
if (( $borrowernumber and $config{update} ) or
(!$borrowernumber and $config{replicate}) ) {
if ( ( $borrowernumber and $config{update} )
or ( !$borrowernumber and $config{replicate} ) )
{
%borrower = ldap_entry_2_hash( $userldapentry, $cardnumber );
#warn "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
}
@ -222,11 +231,8 @@ sub checkpw_ldap {
}
} elsif ( $config{replicate} ) { # A2, C2
my @columns = Koha::Patrons->columns;
$patron = Koha::Patron->new(
{
map { exists( $borrower{$_} ) ? ( $_ => $borrower{$_} ) : () } @columns
}
)->store;
$patron =
Koha::Patron->new( { map { exists( $borrower{$_} ) ? ( $_ => $borrower{$_} ) : () } @columns } )->store;
$patron->discard_changes;
die "Insert of new patron failed" unless $patron;
$borrowernumber = $patron->borrowernumber;
@ -270,7 +276,10 @@ sub checkpw_ldap {
} else {
return 0; # B2, D2
}
if (C4::Context->preference('ExtendedPatronAttributes') && $borrowernumber && ($config{update} ||$config{replicate})) {
if ( C4::Context->preference('ExtendedPatronAttributes')
&& $borrowernumber
&& ( $config{update} || $config{replicate} ) )
{
my $library_id = C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef;
my $attribute_types = Koha::Patron::Attribute::Types->search_with_library_limits( {}, {}, $library_id );
while ( my $attribute_type = $attribute_types->next ) {
@ -307,10 +316,13 @@ sub ldap_entry_2_hash {
# print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
#}
my $x = $userldapentry->{attrs} or return;
foreach ( keys %$x ) {
$memberhash{$_} = join ' ', @{ $x->{$_} };
#warn sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
}
#warn "Finished \%memberhash has ", scalar(keys %memberhash), " keys\n", "Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
foreach my $key ( keys %mapping ) {
my $data = $memberhash{ lc( $mapping{$key}->{is} ) }; # Net::LDAP returns all names in lowercase
@ -320,16 +332,13 @@ sub ldap_entry_2_hash {
}
$borrower{$key} = $data;
}
$borrower{initials} = $memberhash{initials} ||
( substr($borrower{'firstname'},0,1)
. substr($borrower{ 'surname' },0,1)
. " ");
$borrower{initials} = $memberhash{initials}
|| ( substr( $borrower{'firstname'}, 0, 1 ) . substr( $borrower{'surname'}, 0, 1 ) . " " );
# categorycode conversions
if ( defined $categorycode_conversions{ $borrower{categorycode} } ) {
$borrower{categorycode} = $categorycode_conversions{ $borrower{categorycode} };
}
elsif($default_categorycode) {
} elsif ($default_categorycode) {
$borrower{categorycode} = $default_categorycode;
}
@ -339,8 +348,9 @@ sub ldap_entry_2_hash {
$sth->execute( uc( $borrower{'categorycode'} ) );
unless ( my $row = $sth->fetchrow_hashref ) {
my $default = $mapping{'categorycode'}->{content};
#warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
$borrower{'categorycode'} = $default
$borrower{'categorycode'} = $default;
}
return %borrower;
@ -353,11 +363,13 @@ sub exists_local {
my $sth = $dbh->prepare("$select WHERE userid=?"); # was cardnumber=?
$sth->execute($arg);
#warn "Userid '$arg' exists_local? %s\n", $sth->rows;
( $sth->rows == 1 ) and return $sth->fetchrow;
$sth = $dbh->prepare("$select WHERE cardnumber=?");
$sth->execute($arg);
#warn "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
( $sth->rows == 1 ) and return $sth->fetchrow;
return 0;
@ -378,21 +390,18 @@ sub _do_changepassword {
if ( exists( $ldap->{update_password} ) && !$ldap->{update_password} ) {
# We don't store the password in the database
my $sth = C4::Context->dbh->prepare(
'SELECT cardnumber FROM borrowers WHERE borrowernumber=?');
my $sth = C4::Context->dbh->prepare('SELECT cardnumber FROM borrowers WHERE borrowernumber=?');
$sth->execute($borrowerid);
die "Unable to access borrowernumber "
. "with userid=$userid, "
. "borrowernumber=$borrowerid"
die "Unable to access borrowernumber " . "with userid=$userid, " . "borrowernumber=$borrowerid"
if !$sth->rows;
my ($cardnum) = $sth->fetchrow;
$sth = C4::Context->dbh->prepare(
'UPDATE borrowers SET password = null WHERE borrowernumber=?');
$sth = C4::Context->dbh->prepare('UPDATE borrowers SET password = null WHERE borrowernumber=?');
$sth->execute($borrowerid);
return $cardnum;
}
my $digest = hash_password($password);
#warn "changing local password for borrowernumber=$borrowerid to '$digest'\n";
Koha::Patrons->find($borrowerid)->set_password( { password => $password, skip_validation => 1 } );
@ -417,20 +426,18 @@ sub update_local {
while ( my $attribute_type = $attribute_types->next ) {
my $code = $attribute_type->code;
@keys = grep { $_ ne $code } @keys;
#warn "ignoring extended patron attribute '%s' in update_local()\n", $code;
}
}
my $dbh = C4::Context->dbh;
my $query = "UPDATE borrowers\nSET " .
join(',', map {"$_=?"} @keys) .
"\nWHERE borrowernumber=? ";
my $query = "UPDATE borrowers\nSET " . join( ',', map { "$_=?" } @keys ) . "\nWHERE borrowernumber=? ";
my $sth = $dbh->prepare($query);
#warn $query, "\n", join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
#warn "\nuserid = $userid\n";
$sth->execute(
((map {$borrower->{$_}} @keys), $borrowerid)
);
$sth->execute( ( ( map { $borrower->{$_} } @keys ), $borrowerid ) );
# MODIFY PASSWORD/LOGIN if password was mapped
_do_changepassword( $userid, $borrowerid, $password ) if exists( $borrower->{'password'} );

16
C4/Auth_with_shibboleth.pm
View File

@ -31,11 +31,11 @@ use List::MoreUtils qw( any );
use Koha::Logger;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK =
qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
@EXPORT_OK = qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
}
# Check that shib config is not malformed
@ -99,9 +99,11 @@ sub checkpw_shib {
# Does the given shibboleth attribute value ($match) match a valid koha user ?
my $borrowers = Koha::Patrons->search( { $config->{matchpoint} => $match } );
if ( $borrowers->count > 1 ) {
# If we have more than 1 borrower the matchpoint is not unique
# we cannot know which patron is the correct one, so we should fail
Koha::Logger->get->warn("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
Koha::Logger->get->warn(
"There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
return 0;
}
my $borrower = $borrowers->next;
@ -115,6 +117,7 @@ sub checkpw_shib {
if ( $config->{'autocreate'} ) {
return _autocreate( $config, $match );
} else {
# If we reach this point, the user is not a valid koha user
Koha::Logger->get->info("No users with $config->{matchpoint} of $match found and autocreate is disabled");
return 0;
@ -224,6 +227,7 @@ sub _get_return {
my $uri_params_part = '';
foreach my $param ( sort $query->url_param() ) {
# url_param() always returns parameters that were deleted by delete()
# This additional check ensure that parameter was not deleted.
my $uriPiece = $query->param($param);
@ -253,12 +257,10 @@ sub _get_shib_config {
$logger->debug( "koha borrower field to match: " . $config->{matchpoint} );
$logger->debug( "shibboleth attribute to match: " . $config->{mapping}->{ $config->{matchpoint} }->{is} );
return $config;
}
else {
} else {
if ( !$config->{matchpoint} ) {
carp 'shibboleth matchpoint not defined';
}
else {
} else {
carp 'shibboleth matchpoint not mapped';
}
return 0;

192
C4/AuthoritiesMarc.pm
View File

@ -41,6 +41,7 @@ use Koha::SearchEngine::Indexer;
use Koha::SearchEngine::Search;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ -75,7 +76,6 @@ BEGIN {
);
}
=head1 NAME
C4::AuthoritiesMarc
@ -92,12 +92,14 @@ Suppose Kohafield is only linked to ONE subfield
=cut
sub GetAuthMARCFromKohaField {
#AUTHfind_marc_from_kohafield
my ( $kohafield, $authtypecode ) = @_;
my $dbh = C4::Context->dbh;
return 0, 0 unless $kohafield;
$authtypecode = "" unless $authtypecode;
my $sth = $dbh->prepare("select tagfield,tagsubfield from auth_subfield_structure where kohafield= ? and authtypecode=? ");
my $sth = $dbh->prepare(
"select tagfield,tagsubfield from auth_subfield_structure where kohafield= ? and authtypecode=? ");
$sth->execute( $kohafield, $authtypecode );
my ( $tagfield, $tagsubfield ) = $sth->fetchrow;
@ -116,12 +118,14 @@ returns ref to array result and count of results returned
sub SearchAuthorities {
my ( $tags, $and_or, $excluding, $operator, $value, $offset, $length, $authtypecode, $sortby, $skipmetadata ) = @_;
# warn Dumper($tags, $and_or, $excluding, $operator, $value, $offset,$length,$authtypecode,$sortby);
my $dbh = C4::Context->dbh;
$sortby = "" unless $sortby;
my $query;
my $qpquery = '';
my $attr = '';
# the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
# the authtypecode. Then, search on $a of this tag_to_report
# also store main entry MARC tag, to extract it at end of search
@ -149,26 +153,19 @@ sub SearchAuthorities {
if ( @$tags[$i] ) {
if ( @$tags[$i] eq "mainmainentry" ) {
$attr = " \@attr 1=Heading-Main ";
}
elsif ( @$tags[$i] eq "mainentry" ) {
} elsif ( @$tags[$i] eq "mainentry" ) {
$attr = " \@attr 1=Heading ";
}
elsif ( @$tags[$i] eq "match" ) {
} elsif ( @$tags[$i] eq "match" ) {
$attr = " \@attr 1=Match ";
}
elsif ( @$tags[$i] eq "match-heading" ) {
} elsif ( @$tags[$i] eq "match-heading" ) {
$attr = " \@attr 1=Match-heading ";
}
elsif ( @$tags[$i] eq "see-from" ) {
} elsif ( @$tags[$i] eq "see-from" ) {
$attr = " \@attr 1=Match-heading-see-from ";
}
elsif ( @$tags[$i] eq "thesaurus" ) {
} elsif ( @$tags[$i] eq "thesaurus" ) {
$attr = " \@attr 1=Subject-heading-thesaurus ";
}
elsif ( @$tags[$i] eq "all" ) {
} elsif ( @$tags[$i] eq "all" ) {
$attr = " \@attr 1=Any ";
}
else { # Use the index passed in params
} else { # Use the index passed in params
$attr = " \@attr 1=" . @$tags[$i] . " ";
}
} #if @$tags[$i]
@ -178,29 +175,22 @@ sub SearchAuthorities {
my $operator = @$operator[$i];
if ( $operator and $operator eq 'is' ) {
$attr .= " \@attr 4=1 \@attr 5=100 "
; ##Phrase, No truncation,all of subfield field must match
}
elsif ( $operator and $operator eq "=" ) {
$attr .= " \@attr 4=1 \@attr 5=100 "; ##Phrase, No truncation,all of subfield field must match
} elsif ( $operator and $operator eq "=" ) {
$attr .= " \@attr 4=107 "; #Number Exact match
}
elsif ( $operator and $operator eq "start" ) {
} elsif ( $operator and $operator eq "start" ) {
$attr .= " \@attr 3=2 \@attr 4=1 \@attr 5=1 \@attr 6=3 "
; #Firstinfield Phrase, Right truncated, Complete field
}
elsif ( $operator and $operator eq "exact" ) {
$attr .= " \@attr 4=1 \@attr 5=100 \@attr 6=3 "
; ##Phrase, No truncation,all of subfield field must match
}
else {
$attr .= " \@attr 5=1 \@attr 4=6 "
; ## Word list, right truncated, anywhere
} elsif ( $operator and $operator eq "exact" ) {
$attr .=
" \@attr 4=1 \@attr 5=100 \@attr 6=3 "; ##Phrase, No truncation,all of subfield field must match
} else {
$attr .= " \@attr 5=1 \@attr 4=6 "; ## Word list, right truncated, anywhere
if ( $sortby eq 'Relevance' ) {
$attr .= "\@attr 2=102 ";
}
}
@$value[$i] =~
s/"/\\"/g; # Escape the double-quotes in the search value
@$value[$i] =~ s/"/\\"/g; # Escape the double-quotes in the search value
$attr = $attr . "\"" . @$value[$i] . "\"";
$q2 .= $attr;
$dosearch = 1;
@ -209,22 +199,28 @@ sub SearchAuthorities {
}
##Add how many queries generated
if ( defined $query && $query =~ /\S+/ ) {
#NOTE: This code path is used by authority search in cataloguing plugins...
#FIXME: This does not quite work the way the author probably intended.
#It creates a ($query prefix) AND (query 1) AND (query 2) structure instead of
#($query prefix) AND (query 1 AND query 2)
$query = $and x $attr_cnt . $query . ( defined $q2 ? $q2 : '' );
} else {
#NOTE: This code path is used by authority search in authority home and record matching rules...
my $op_prefix = '';
#NOTE: Without the following code, multiple queries will never be joined together
#with a Boolean operator.
if ( $attr_cnt > 1 ) {
#NOTE: We always need 1 less operator than we have operands,
#so long as there is more than 1 operand
my $or_cnt = $attr_cnt - 1;
#NOTE: We hard-code OR here because that's what Elasticsearch does
$op_prefix = ' @or ' x $or_cnt;
#NOTE: This evaluates to a logical structure like (query 1) OR (query 2) OR (query 3)
}
$query = $op_prefix . $q2;
@ -253,6 +249,7 @@ sub SearchAuthorities {
my $Anewq = ZOOM::Query::PQF->new( $query, $oAuth[0] );
my $oAResult;
$oAResult = $oAuth[0]->search($Anewq);
while ( ( $i = ZOOM::event( \@oAuth ) ) != 0 ) {
my $ev = $oAuth[ $i - 1 ]->last_event();
last if $ev == ZOOM::Event::ZEND;
@ -321,6 +318,7 @@ sub SearchAuthorities {
my $summary = BuildSummary( $authrecord, $authid, $thisauthtypecode );
if ( C4::Context->preference('ShowHeadingUse') ) {
# checking valid heading use
my $f008 = $authrecord->field('008');
if ($f008) {
@ -352,6 +350,7 @@ sub SearchAuthorities {
} ## if nbresult
NOLUCK:
$oAResult->destroy();
# $oAuth[0]->destroy();
return ( \@finalresult, $nbresults );
@ -385,6 +384,7 @@ sub GuessAuthTypeCode {
'182' => { authtypecode => 'CHRON_SUBD' },
'185' => { authtypecode => 'FORM_SUBD' },
},
#200 Personal name 700, 701, 702 4-- with embedded 700, 701, 702 600
# 604 with embedded 700, 701, 702
#210 Corporate or meeting name 710, 711, 712 4-- with embedded 710, 711, 712 601 604 with embedded 710, 711, 712
@ -429,7 +429,8 @@ sub GuessAuthTypeCode {
}
};
foreach my $field ( keys %{ $heading_fields->{ uc( C4::Context->preference('marcflavour') ) } } ) {
return $heading_fields->{uc(C4::Context->preference('marcflavour'))}->{$field}->{'authtypecode'} if (defined $record->field($field));
return $heading_fields->{ uc( C4::Context->preference('marcflavour') ) }->{$field}->{'authtypecode'}
if ( defined $record->field($field) );
}
return;
}
@ -445,6 +446,7 @@ Get the record and tries to guess the adequate authtypecode from its content.
sub GuessAuthId {
my ($record) = @_;
return unless ( $record && $record->field('001') );
# my $authtypecode=GuessAuthTypeCode($record);
# my ($tag,$subfield)=GetAuthMARCFromKohaField("auth_header.authid",$authtypecode);
# if ($tag > 010) {return $record->subfield($tag,$subfield)}
@ -486,7 +488,6 @@ sub GetTagsLabels {
my $sth;
my $libfield = ($forlibrarian) ? 'liblibrarian' : 'libopac';
# check that authority exists
$sth = $dbh->prepare("SELECT count(*) FROM auth_tag_structure WHERE authtypecode=?");
$sth->execute($authtypecode);
@ -527,10 +528,12 @@ ORDER BY tagfield, display_order, tagsubfield"
my $display_order;
while (
( $tag, $subfield, $liblibrarian, , $libopac, $tab,
(
$tag, $subfield, $liblibrarian,, $libopac, $tab,
$mandatory, $repeatable, $authorised_value, $authtypecode,
$value_builder, $kohafield, $seealso, $hidden,
$isurl, $defaultvalue, $display_order )
$isurl, $defaultvalue, $display_order
)
= $sth->fetchrow
)
{
@ -688,6 +691,7 @@ sub AddAuthority {
$action = 'modify';
$authority = Koha::Authorities->find($authid);
$authority->authtypecode($authtypecode);
# In the case we are changing type we need to set this to ensure heading field is correctly chosen
}
@ -768,10 +772,13 @@ sub ModAuthority {
my $skip_record_index = $params->{skip_record_index} || 0;
my $oldrecord = GetAuthority($authid);
#Now rewrite the $record to table with an add
$authid = AddAuthority( $record, $authid, $authtypecode, { skip_record_index => $skip_record_index } );
merge({ mergefrom => $authid, MARCfrom => $oldrecord, mergeto => $authid, MARCto => $record }) if !$params->{skip_merge};
logaction( "AUTHORITIES", "MODIFY", $authid, "authority BEFORE=>" . $oldrecord->as_formatted ) if C4::Context->preference("AuthoritiesLog");
merge( { mergefrom => $authid, MARCfrom => $oldrecord, mergeto => $authid, MARCto => $record } )
if !$params->{skip_merge};
logaction( "AUTHORITIES", "MODIFY", $authid, "authority BEFORE=>" . $oldrecord->as_formatted )
if C4::Context->preference("AuthoritiesLog");
return $authid;
}
@ -784,6 +791,7 @@ returns xml form of record $authid
=cut
sub GetAuthorityXML {
# Returns MARC::XML of the authority passed in parameter.
my ($authid) = @_;
if ( uc( C4::Context->preference('marcflavour') ) eq 'UNIMARC' ) {
@ -792,8 +800,8 @@ sub GetAuthorityXML {
$sth->execute($authid);
my ($marcxml) = $sth->fetchrow;
return $marcxml;
}
else {
} else {
# for MARC21, call GetAuthority instead of
# getting the XML directly since we may
# need to fix up the location of the authority
@ -835,25 +843,30 @@ sub FindDuplicateAuthority {
my ( $record, $authtypecode ) = @_;
my $dbh = C4::Context->dbh;
my $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report;
# build a request for SearchAuthorities
my $op = 'AND';
my $query = 'at:"' . $authtypecode . '" '; # Quote authtype code to avoid unescaping slash in GENRE/FORM later
my $filtervalues = qr([\001-\040\Q!'"`#$%&*+,-./:;<=>?@(){[}_|~\E\]]);
if ( $record->field($auth_tag_to_report) ) {
foreach ( $record->field($auth_tag_to_report)->subfields() ) {
$_->[1]=~s/$filtervalues/ /g; $query.= " $op he:\"".$_->[1]."\"" if ($_->[0]=~/[A-z]/);
$_->[1] =~ s/$filtervalues/ /g;
$query .= " $op he:\"" . $_->[1] . "\"" if ( $_->[0] =~ /[A-z]/ );
}
}
my $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
my ( $error, $results, $total_hits ) = $searcher->simple_search_compat( $query, 0, 1, ['authorityserver'] );
# there is at least 1 result => return the 1st one
if ( !defined $error && @{$results} ) {
my $marcrecord = C4::Search::new_record_from_zebra(
'authorityserver',
$results->[0]
);
return $marcrecord->field('001')->data,BuildSummary($marcrecord,$marcrecord->field('001')->data,$authtypecode);
return $marcrecord->field('001')->data,
BuildSummary( $marcrecord, $marcrecord->field('001')->data, $authtypecode );
}
# no result, returns nothing
return;
}
@ -876,6 +889,7 @@ sub BuildSummary {
my $dbh = C4::Context->dbh;
my %summary;
my $summary_template;
# handle $authtypecode is NULL or eq ""
if ($authtypecode) {
my $authref = Koha::Authority::Types->find($authtypecode);
@ -883,6 +897,7 @@ sub BuildSummary {
$summary{authtypecode} = $authref->authtypecode;
$summary{type} = $authref->authtypetext;
$summary_template = $authref->summary;
# for MARC21, the authority type summary displays a label meant for
# display
if ( C4::Context->preference('marcflavour') ne 'UNIMARC' ) {
@ -893,7 +908,8 @@ sub BuildSummary {
}
}
my $marc21subfields = 'abcdfghjklmnopqrstuvxyz68';
my %marc21controlrefs = ( 'a' => 'earlier',
my %marc21controlrefs = (
'a' => 'earlier',
'b' => 'later',
'd' => 'acronym',
'f' => 'musical',
@ -915,8 +931,10 @@ sub BuildSummary {
$thesaurus{'4'} = "Chronologie";
$thesaurus{'5'} = "Lieux";
$thesaurus{'6'} = "Sujets";
#thesaurus a remplir
my $reported_tag;
# if the library has a summary defined, use it. Otherwise, build a standard one
# FIXME - it appears that the summary field in the authority frameworks
# can work as a display template. However, this doesn't
@ -963,6 +981,7 @@ sub BuildSummary {
my @equalterm;
if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
# construct UNIMARC summary, that is quite different from MARC21 one
# accepted form
foreach my $field ( $record->field('2..') ) {
@ -972,6 +991,7 @@ sub BuildSummary {
field => $field->tag(),
};
}
# rejected form(s)
foreach my $field ( $record->field('3..') ) {
push @notes, { note => $field->subfield('a'), field => $field->tag() };
@ -1001,14 +1021,17 @@ sub BuildSummary {
} $record->field('5..');
# Other forms
@otherscript = map { {
@otherscript = map {
{
lang => length( $_->subfield('8') ) == 6 ? substr( $_->subfield('8'), 3, 3 ) : $_->subfield('8') || '',
term => $_->subfield('a') . ( $_->subfield('b') ? ', ' . $_->subfield('b') : '' ),
direction => 'ltr',
field => $_->tag,
} } $record->field('7..');
}
} $record->field('7..');
} else {
# construct MARC21 summary
# FIXME - looping over 1XX is questionable
# since MARC21 authority should have only one 1XX
@ -1020,6 +1043,7 @@ sub BuildSummary {
foreach my $field ( $record->field('1..') ) {
my $tag = $field->tag();
next if "152" eq $tag;
# FIXME - 152 is not a good tag to use
# in MARC21 -- purely local tags really ought to be
# 9XX
@ -1177,7 +1201,11 @@ sub BuildSummary {
$type = $category;
}
my $direction = $linkage =~ m#/r$# ? 'rtl' : 'ltr';
push @otherscript, { term => $field->as_string($subfields_to_report), category => $category, type => $type, direction => $direction, linkage => $linkage };
push @otherscript,
{
term => $field->as_string($subfields_to_report), category => $category, type => $type,
direction => $direction, linkage => $linkage
};
}
}
$summary{mainentry} = $authorized[0]->{heading};
@ -1211,6 +1239,7 @@ sub GetAuthorizedHeading {
}
return unless ( ref $record eq 'MARC::Record' );
if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
# construct UNIMARC summary, that is quite different from MARC21 one
# accepted form
foreach my $field ( $record->field('2..') ) {
@ -1242,6 +1271,7 @@ sub CompareFieldWithAuthority {
my $record = GetAuthority( $args->{authid} );
return unless ( ref $record eq 'MARC::Record' );
if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
# UNIMARC has same subfields for bibs and authorities
foreach my $field ( $record->field('2..') ) {
return compare_fields( $field, $args->{field}, 'abcdefghijlmnopqrstuvwxyz' );
@ -1272,6 +1302,7 @@ Example of text:
sub BuildAuthHierarchies {
my $authid = shift @_;
# warn "authid : $authid";
my $force = shift @_ || ( C4::Context->preference('marcflavour') eq 'UNIMARC' ? 0 : 1 );
my @globalresult;
@ -1280,6 +1311,7 @@ sub BuildAuthHierarchies{
my $data = GetHeaderAuthority($authid);
if ( $data->{'authtrees'} and not $force ) {
return $data->{'authtrees'};
# } elsif ($data->{'authtrees'}){
# $hierarchies=$data->{'authtrees'};
} else {
@ -1288,9 +1320,17 @@ sub BuildAuthHierarchies{
return unless $record;
foreach my $field ( $record->field('5..') ) {
my $broader = 0;
$broader = 1 if (
(C4::Context->preference('marcflavour') eq 'UNIMARC' && $field->subfield('5') && $field->subfield('5') eq 'g') ||
(C4::Context->preference('marcflavour') ne 'UNIMARC' && $field->subfield('w') && substr($field->subfield('w'), 0, 1) eq 'g'));
$broader = 1
if (
(
C4::Context->preference('marcflavour') eq 'UNIMARC'
&& $field->subfield('5')
&& $field->subfield('5') eq 'g'
)
|| ( C4::Context->preference('marcflavour') ne 'UNIMARC'
&& $field->subfield('w')
&& substr( $field->subfield('w'), 0, 1 ) eq 'g' )
);
if ($broader) {
my $subfauthid = _get_authid_subfield($field) || '';
next if ( $subfauthid eq $authid );
@ -1300,6 +1340,7 @@ sub BuildAuthHierarchies{
my $trees;
$trees = BuildAuthHierarchies($subfauthid);
my @trees;
if ( $trees =~ /;/ ) {
@trees = split( /;/, $trees );
} else {
@ -1313,6 +1354,7 @@ sub BuildAuthHierarchies{
}
$hierarchies = join( ";", @globalresult );
}
#Unless there is no ancestor, I am alone.
$hierarchies = "$authid" unless ($hierarchies);
}
@ -1342,20 +1384,22 @@ sub BuildAuthHierarchy{
return unless ( $record && $record->field('001') );
my $authid = $record->field('001')->data();
my %cell;
my $parents=""; my $children="";
my $parents = "";
my $children = "";
my ( @loopparents, @loopchildren );
my $marcflavour = C4::Context->preference('marcflavour');
my $relationshipsf = $marcflavour eq 'UNIMARC' ? '5' : 'w';
foreach my $field ( $record->field('5..') ) {
my $subfauthid = _get_authid_subfield($field);
if ( $subfauthid && $field->subfield($relationshipsf) && $field->subfield('a') ) {
my $relationship = substr( $field->subfield($relationshipsf), 0, 1 );
if ( $relationship eq 'h' ) {
push @loopchildren, { "authid" => $subfauthid, "value" => $field->subfield('a') };
}
elsif ($relationship eq 'g'){
} elsif ( $relationship eq 'g' ) {
push @loopparents, { "authid" => $subfauthid, "value" => $field->subfield('a') };
}
# brothers could get in there with an else
}
}
@ -1364,7 +1408,10 @@ sub BuildAuthHierarchy{
$cell{"class"} = $class;
$cell{"authid"} = $authid;
$cell{"current_value"} = 1 if ( $authid eq $authid_constructed );
$cell{"value"}=C4::Context->preference('marcflavour') eq 'UNIMARC' ? $record->subfield('2..',"a") : $record->subfield('1..', 'a');
$cell{"value"} =
C4::Context->preference('marcflavour') eq 'UNIMARC'
? $record->subfield( '2..', "a" )
: $record->subfield( '1..', 'a' );
return \%cell;
}
@ -1391,6 +1438,7 @@ sub BuildAuthHierarchyBranch {
my $nextBranch = BuildAuthHierarchyBranch( $tree, $authid, ++$cnt );
my $nextAuthid = $nextBranch->{authid};
my $found;
# If we already have the next branch listed as a child, let's
# replace the old listing with the new one. If not, we will add
# the branch at the end.
@ -1523,11 +1571,13 @@ sub merge {
if ( $hits > 0 && $hits <= $max ) {
@biblionumbers = Koha::Authorities->linked_biblionumbers( { authid => $mergefrom } );
} elsif ( $hits > $max ) { #postpone this merge to the cron job
Koha::Authority::MergeRequest->new({
Koha::Authority::MergeRequest->new(
{
authid => $mergefrom,
oldrecord => $MARCfrom,
authid_new => $mergeto,
})->store;
}
)->store;
}
}
return 0 if !@biblionumbers;
@ -1538,9 +1588,11 @@ sub merge {
my $authtypefrom;
my $authtypeto = $authto ? Koha::Authority::Types->find( $authto->authtypecode ) : undef;
if ( $mergeto && $mergefrom == $mergeto && $MARCfrom ) {
# bulkmarcimport may have changed the authtype; see BZ 19693
my $old_type = $MARCfrom->subfield( get_auth_type_location() ); # going via default
if ( $old_type && $authto && $old_type ne $authto->authtypecode ) {
# Type change: handled by simulating a postponed merge where the auth record has been deleted already
# This triggers a walk through all auth controlled tags
undef $authfrom;
@ -1551,7 +1603,9 @@ sub merge {
my $auth_tag_to_report_to = $authtypeto ? $authtypeto->auth_tag_to_report : '';
my @record_to;
@record_to = $MARCto->field($auth_tag_to_report_to)->subfields() if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
@record_to = $MARCto->field($auth_tag_to_report_to)->subfields()
if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
# Exceptional: If MARCto and authtypeto exist but $auth_tag_to_report_to
# is empty, make sure that $9 and $a remain (instead of clearing the
# reference) in order to allow for data recovery.
@ -1562,6 +1616,7 @@ sub merge {
my @record_from;
if ( !$authfrom && $MARCfrom && $MARCfrom->field( '1..', '2..' ) ) {
# postponed merge, authfrom was deleted and MARCfrom only contains the old reporting tag (and possibly a 100 for UNIMARC)
# 2XX is for UNIMARC; we use -1 in order to skip 100 in UNIMARC; this will not impact MARC21, since there is only one tag
@record_from = ( $MARCfrom->field( '1..', '2..' ) )[-1]->subfields;
@ -1574,7 +1629,11 @@ sub merge {
# For a deleted authority record, we scan all auth controlled fields
my $dbh = C4::Context->dbh;
my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
my $tags_using_authtype = $authtypefrom && $authtypefrom->authtypecode ? $dbh->selectcol_arrayref( $sql, undef, ( $authtypefrom->authtypecode )) : $dbh->selectcol_arrayref( "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode IS NOT NULL AND authtypecode<>''" );
my $tags_using_authtype =
$authtypefrom && $authtypefrom->authtypecode
? $dbh->selectcol_arrayref( $sql, undef, ( $authtypefrom->authtypecode ) )
: $dbh->selectcol_arrayref(
"SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode IS NOT NULL AND authtypecode<>''");
my $tags_new;
if ( $authtypeto && ( !$authtypefrom || $authtypeto->authtypecode ne $authtypefrom->authtypecode ) ) {
$tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ) );
@ -1582,6 +1641,7 @@ sub merge {
my $overwrite = C4::Context->preference('AuthorityMergeMode') eq 'strict';
my $skip_subfields = $overwrite
# This hash contains all subfields from the authority report fields
# Including $MARCfrom as well as $MARCto
# We only need it in loose merge mode; replaces the former $exclude
@ -1602,15 +1662,18 @@ sub merge {
my $tag = $field->tag();
next if !defined($auth_number) || $auth_number ne $mergefrom;
$countfrom++;
if ( !$mergeto || !@record_to ||
( $overwrite && $countfrom > 1 ) ) {
if ( !$mergeto
|| !@record_to
|| ( $overwrite && $countfrom > 1 ) )
{
# !mergeto or !record_to indicates a delete
# Other condition: remove this duplicate in strict mode
$marcrecord->delete_field($field);
$update = 1;
next;
}
my $newtag = $tags_new && @$tags_new
my $newtag =
$tags_new && @$tags_new
? _merge_newtag( $tag, $tags_new )
: $tag;
my $controlled_ind = $authto->controlled_indicators( { record => $MARCto, biblio_tag => $newtag } );
@ -1622,6 +1685,7 @@ sub merge {
);
my ( @prefix, @postfix );
if ( !$overwrite ) {
# add subfields back in loose mode, check skip_subfields
# The first extra subfields will be in front of the
# controlled block, the rest at the end.
@ -1629,6 +1693,7 @@ sub merge {
foreach my $subfield ( $field->subfields ) {
next if $subfield->[0] eq '9'; # skip but leave flag
if ( $skip_subfields->{ $subfield->[0] } ) {
# This marks the beginning of the controlled block
$prefix_flag = 0;
next;
@ -1645,13 +1710,16 @@ sub merge {
}
if ( exists $controlled_ind->{sub2} ) { # thesaurus info
if ( defined $controlled_ind->{sub2} ) {
# Add or replace
$field_to->update( 2 => $controlled_ind->{sub2} );
} else {
# Key alerts us here to remove $2
$field_to->delete_subfield( code => '2' );
}
}
# Move $9 to the end
$field_to->delete_subfield( code => '9' );
$field_to->add_subfields( 9 => $mergeto );
@ -1673,6 +1741,7 @@ sub merge {
}
sub _merge_newtag {
# Routine is only called for an (exceptional) authtypecode change
# Fixes old behavior of returning the first tag found
my ( $oldtag, $new_tags ) = @_;
@ -1683,6 +1752,7 @@ sub _merge_newtag {
if ( grep { $_ eq $guess } @$new_tags ) {
return $guess;
}
# Otherwise return one from the same block e.g. 6XX for 650
# If not there too, fall back to first new tag (old behavior!)
my @same_block = grep { /^$prefix/ } @$new_tags;
@ -1690,6 +1760,7 @@ sub _merge_newtag {
}
sub append_fields_ordered {
# while we lack this function in MARC::Record
# we do not want insert_fields_ordered since it inserts before
my ( $record, $field ) = @_;
@ -1750,7 +1821,6 @@ sub compare_fields {
return 1;
}
=head2 _after_authority_action_hooks
Helper method that takes care of calling all plugin hooks

18
C4/Barcodes.pm
View File

@ -43,23 +43,28 @@ sub _prefformat {
sub initial {
return '0000001';
}
sub width {
return;
}
sub process_head { # (self,head,whole,specific)
my $self = shift;
return shift; # Default: just return the head unchanged.
}
sub process_tail { # (self,tail,whole,specific)
my $self = shift;
return shift; # Default: just return the tail unchanged.
}
sub is_max {
my $self = shift;
ref($self) or carp "Called is_max on a non-object: '$self'";
(@_) and $self->{is_max} = shift;
return $self->{is_max} || 0;
}
sub value {
my $self = shift;
if (@_) {
@ -70,6 +75,7 @@ sub value {
}
return $self->{value};
}
sub autoBarcode {
(@_) or return _prefformat;
my $self = shift;
@ -77,6 +83,7 @@ sub autoBarcode {
$value =~ s/^.*:://; # in case we get C4::Barcodes::incremental, we just want 'incremental'
return $value;
}
sub parse { # return 3 parts of barcode: non-incrementing, incrementing, non-incrementing
my $self = shift;
my $barcode = (@_) ? shift : $self->value;
@ -86,6 +93,7 @@ sub parse { # return 3 parts of barcode: non-incrementing, incrementing, non-inc
}
return ( $1, $2, '' ); # the third part is in anticipation of barcodes that include checkdigits
}
sub max {
my $self = shift;
if ( $self->{is_max} ) {
@ -93,6 +101,7 @@ sub max {
}
return $self->db_max;
}
sub db_max {
my $self = shift;
my $query = "SELECT max(abs(CAST(barcode AS UNSIGNED))) FROM items LIMIT 1"
@ -101,6 +110,7 @@ sub db_max {
$sth->execute();
return $sth->fetchrow_array || $self->initial;
}
sub next_value {
my $self = shift;
my $specific = ( scalar @_ ) ? 1 : 0;
@ -125,21 +135,25 @@ sub next_value {
my $next_value = $head . $incr . $tail;
return $next_value;
}
sub next {
my $self = shift or return;
(@_) and $self->{next} = shift;
return $self->{next};
}
sub previous {
my $self = shift or return;
(@_) and $self->{previous} = shift;
return $self->{previous};
}
sub serial {
my $self = shift or return;
(@_) and $self->{serial} = shift;
return $self->{serial};
}
sub default_self {
(@_) or carp "default_self called with no argument. Reverting to _prefformat.";
my $autoBarcode = (@_) ? shift : _prefformat;
@ -182,7 +196,9 @@ sub new {
return bless $self, $class_or_object;
} elsif ($from_obj) {
$class_or_object->autoBarcode eq $autoBarcodeType
or carp "Cannot create Barcodes object (type '$autoBarcodeType') from " . $class_or_object->autoBarcode . " object!";
or carp "Cannot create Barcodes object (type '$autoBarcodeType') from "
. $class_or_object->autoBarcode
. " object!";
$self = $class_or_object->new_object(@_);
$self->serial( $class_or_object->serial + 1 );
if ( $class_or_object->is_max ) {

3
C4/Barcodes/ValueBuilder.pm
View File

@ -25,6 +25,7 @@ use C4::Context;
sub get_barcode {
my ($args) = @_;
my $nextnum;
# not the best, two catalogers could add the same barcode easily this way :/
my $query = "select max(cast(barcode as unsigned)) from items";
my $sth = C4::Context->dbh->prepare($query);
@ -73,7 +74,6 @@ sub get_barcode {
return $nextnum, $scr;
}
package C4::Barcodes::ValueBuilder::annual;
use C4::Context;
@ -94,7 +94,6 @@ sub get_barcode {
1;
=head1 Barcodes::ValueBuilder
This module is intended as a shim to ease the eventual transition from

17
C4/Barcodes/annual.pm
View File

@ -37,13 +37,16 @@ BEGIN {
sub db_max {
my $self = shift;
my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
my $query =
"SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)
my $sth = C4::Context->dbh->prepare($query);
my ($iso);
if (@_) {
my $input = shift;
$iso = output_pref({ dt => dt_from_string( $input, 'iso' ), dateformat => 'iso', dateonly => 1 }); # try to set the date w/ 2nd arg
$iso = output_pref( { dt => dt_from_string( $input, 'iso' ), dateformat => 'iso', dateonly => 1 } )
; # try to set the date w/ 2nd arg
unless ($iso) {
warn "Failed to create 'iso' Dates object with input '$input'. Reverting to today's date.";
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # failover back to today
@ -59,7 +62,9 @@ sub db_max {
sub initial () {
my $self = shift;
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
return
substr( output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ), 0, 4 ) . '-'
. sprintf( '%' . "$width.$width" . 'd', 1 );
}
sub parse {
@ -71,15 +76,19 @@ sub parse {
}
return ( $1, $2, '' ); # the third part is in anticipation of barcodes that include checkdigits
}
sub width {
my $self = shift;
(@_) and $width = shift; # hitting the class variable.
return $width;
}
sub process_head {
my ( $self, $head, $whole, $specific ) = @_;
$specific and return $head; # if this is built off an existing barcode, just return the head unchanged.
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-
return
substr( output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ), 0, 4 )
. '-'; # else get new YYYY-
}
sub new_object {

10
C4/Barcodes/hbyymmincr.pm
View File

@ -40,12 +40,14 @@ BEGIN {
sub db_max {
my $self = shift;
my $width = WIDTH;
my $query = "SELECT SUBSTRING(barcode,-$width) AS chunk, barcode FROM items WHERE barcode REGEXP ? ORDER BY chunk DESC LIMIT 1";
my $query =
"SELECT SUBSTRING(barcode,-$width) AS chunk, barcode FROM items WHERE barcode REGEXP ? ORDER BY chunk DESC LIMIT 1";
my $sth = C4::Context->dbh->prepare($query);
my ($iso);
if (@_) {
my $input = shift;
$iso = output_pref({ dt => dt_from_string( $input, 'iso' ), dateformat => 'iso', dateonly => 1 }); # try to set the date w/ 2nd arg
$iso = output_pref( { dt => dt_from_string( $input, 'iso' ), dateformat => 'iso', dateonly => 1 } )
; # try to set the date w/ 2nd arg
unless ($iso) {
warn "Failed to create 'iso' Dates object with input '$input'. Reverting to today's date.";
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # failover back to today
@ -55,7 +57,8 @@ sub db_max {
}
my $year = substr( $iso, 2, 2 ); # i.e. "08" for 2008
my $andtwo = $width + 2;
$sth->execute("^[a-zA-Z]{1,}" . $year . "[0-9]{$andtwo}"); # the extra two digits are the month. we don't care what they are, just that they are there.
$sth->execute( "^[a-zA-Z]{1,}" . $year . "[0-9]{$andtwo}" )
; # the extra two digits are the month. we don't care what they are, just that they are there.
unless ( $sth->rows ) {
warn "No existing hbyymmincr barcodes found. Reverting to initial value.";
return $self->initial;
@ -67,6 +70,7 @@ sub db_max {
sub initial {
my $self = shift;
# FIXME: populated branch?
my $iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # like "2008-07-02"
warn "HBYYMM Barcode was not passed a branch, default is blank" if ( $self->branch eq '' );

348
C4/Biblio.pm
View File

@ -22,6 +22,7 @@ package C4::Biblio;
use Modern::Perl;
use vars qw(@ISA @EXPORT_OK);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -422,7 +423,8 @@ sub ModBiblio {
# throw an exception which probably won't be handled.
foreach my $field ( $record->fields() ) {
if ( !$field->is_control_field() ) {
if (scalar($field->subfields()) == 0 || (scalar($field->subfields()) == 1 && $field->subfield('9'))) {
if ( scalar( $field->subfields() ) == 0 || ( scalar( $field->subfields() ) == 1 && $field->subfield('9') ) )
{
$record->delete_field($field);
}
}
@ -478,11 +480,9 @@ sub ModBiblio {
C4::OAI::Sets::UpdateOAISetsBiblio( $biblionumber, $record );
}
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
{
biblio_ids => [ $biblionumber ]
}
) unless $options->{skip_holds_queue} or !C4::Context->preference('RealTimeHoldsQueue');
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue( { biblio_ids => [$biblionumber] } )
unless $options->{skip_holds_queue}
or !C4::Context->preference('RealTimeHoldsQueue');
return 1;
}
@ -499,6 +499,7 @@ MARC bib.
sub _strip_item_fields {
my $record = shift;
my $frameworkcode = shift;
# get the items before and append them to the biblio before updating the record, atm we just have the biblio
my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField("items.itemnumber");
@ -566,6 +567,7 @@ sub DelBiblio {
# We update any existing orders
my $orders = $biblio->orders;
$orders->update( { deleted_biblionumber => $biblionumber }, { no_triggers => 1 } );
# Update related ILL requests
$biblio->ill_requests->update( { deleted_biblio_id => $biblio->id, biblio_id => undef } );
@ -584,7 +586,6 @@ sub DelBiblio {
return $error if $error;
}
# delete biblio from Koha tables and save in deletedbiblio
# must do this *after* _koha_delete_biblioitems, otherwise
# delete cascade will prevent deletedbiblioitems rows
@ -595,16 +596,13 @@ sub DelBiblio {
logaction( "CATALOGUING", "DELETE", $biblionumber, "biblio" ) if C4::Context->preference("CataloguingLog");
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
{
biblio_ids => [ $biblionumber ]
}
) unless $params->{skip_holds_queue} or !C4::Context->preference('RealTimeHoldsQueue');
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue( { biblio_ids => [$biblionumber] } )
unless $params->{skip_holds_queue}
or !C4::Context->preference('RealTimeHoldsQueue');
return;
}
=head2 BiblioAutoLink
my $headings_linked = BiblioAutoLink($record, $frameworkcode)
@ -626,8 +624,7 @@ sub BiblioAutoLink {
}
my ( $num_headings_changed, %results );
my $linker_module =
"C4::Linker::" . ( C4::Context->preference("LinkerModule") || 'Default' );
my $linker_module = "C4::Linker::" . ( C4::Context->preference("LinkerModule") || 'Default' );
unless ( can_load( modules => { $linker_module => undef } ) ) {
$linker_module = 'C4::Linker::Default';
unless ( can_load( modules => { $linker_module => undef } ) ) {
@ -635,10 +632,12 @@ sub BiblioAutoLink {
}
}
my $linker = $linker_module->new(
{ 'options' => C4::Context->preference("LinkerOptions") } );
my ( $headings_changed, $results ) =
LinkBibHeadingsToAuthorities( $linker, $record, $frameworkcode, C4::Context->preference("CatalogModuleRelink") || '', undef, $verbose );
my $linker = $linker_module->new( { 'options' => C4::Context->preference("LinkerOptions") } );
my ( $headings_changed, $results ) = LinkBibHeadingsToAuthorities(
$linker, $record, $frameworkcode,
C4::Context->preference("CatalogModuleRelink") || '', undef, $verbose
);
# By default we probably don't want to relink things when cataloging
return $headings_changed, $results;
}
@ -671,6 +670,7 @@ sub LinkBibHeadingsToAuthorities {
my $verbose = shift;
my %results;
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
if ( !$bib ) {
carp 'LinkBibHeadingsToAuthorities called on undefined bib record';
return ( 0, {} );
@ -690,28 +690,30 @@ sub LinkBibHeadingsToAuthorities {
# check existing $9
my $current_link = $field->subfield('9');
if ( defined $current_link && (!$allowrelink || !C4::Context->preference('LinkerRelink')) )
{
if ( defined $current_link && ( !$allowrelink || !C4::Context->preference('LinkerRelink') ) ) {
$results{'linked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
push( @{ $results{'details'} }, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED' } )
if $verbose;
next;
}
my ( $authid, $fuzzy, $match_count ) = $linker->get_link($heading);
if ($authid) {
$results{ $fuzzy ? 'fuzzy' : 'linked' }
->{ $heading->display_form() }++;
$results{ $fuzzy ? 'fuzzy' : 'linked' }->{ $heading->display_form() }++;
if ( defined $current_link and $current_link == $authid ) {
push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
push(
@{ $results{'details'} },
{ tag => $field->tag(), authid => $current_link, status => 'UNCHANGED' }
) if $verbose;
next;
}
$field->delete_subfield( code => '9' ) if defined $current_link;
$field->add_subfields( '9', $authid );
$num_headings_changed++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'LOCAL_FOUND'}) if $verbose;
}
else {
push( @{ $results{'details'} }, { tag => $field->tag(), authid => $authid, status => 'LOCAL_FOUND' } )
if $verbose;
} else {
my $authority_type =
$memory_cache->get_from_cache( "LinkBibHeadingsToAuthorities:AuthorityType:" . $heading->auth_type() );
unless ($authority_type) {
@ -725,14 +727,22 @@ sub LinkBibHeadingsToAuthorities {
&& ( !$allowrelink || C4::Context->preference('LinkerKeepStale') ) )
{
$results{'fuzzy'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
}
elsif ( C4::Context->preference('AutoCreateAuthorities') ) {
push(
@{ $results{'details'} },
{ tag => $field->tag(), authid => $current_link, status => 'UNCHANGED' }
) if $verbose;
} elsif ( C4::Context->preference('AutoCreateAuthorities') ) {
if ( _check_valid_auth_link( $current_link, $field ) ) {
$results{'linked'}->{ $heading->display_form() }++;
} elsif ( $match_count > 1 ) {
$results{'unlinked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'MULTIPLE_MATCH', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
push(
@{ $results{'details'} },
{
tag => $field->tag(), authid => undef, status => 'MULTIPLE_MATCH',
auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report
}
) if $verbose;
} elsif ( !$match_count ) {
my $marcrecordauth = MARC::Record->new();
if ( C4::Context->preference('marcflavour') eq 'MARC21' ) {
@ -744,12 +754,12 @@ sub LinkBibHeadingsToAuthorities {
my @auth_subfields;
foreach my $subfield ( $field->subfields() ) {
if ( $subfield->[0] =~ /[A-z]/
&& C4::Heading::valid_heading_subfield(
$field->tag, $subfield->[0] )
){
&& C4::Heading::valid_heading_subfield( $field->tag, $subfield->[0] ) )
{
push @auth_subfields, $subfield->[0] => $subfield->[1];
}
}
# Bib headings contain some ending punctuation that should NOT
# be included in the authority record. Strip those before creation
next unless @auth_subfields; # Don't try to create a record if we have no fields;
@ -778,52 +788,67 @@ sub LinkBibHeadingsToAuthorities {
'a' => C4::Context->preference('GenerateAuthorityField667')
)
);
my $cite =
$bib->author() . ", "
. $bib->title_proper() . ", "
. $bib->publication_date() . " ";
my $cite = $bib->author() . ", " . $bib->title_proper() . ", " . $bib->publication_date() . " ";
$cite =~ s/^[\s\,]*//;
$cite =~ s/[\s\,]*$//;
$cite =
C4::Context->preference('GenerateAuthorityField670') . ": ("
. ( $library ? $library->get_effective_marcorgcode : C4::Context->preference('MARCOrgCode') ) . ")"
. (
$library ? $library->get_effective_marcorgcode : C4::Context->preference('MARCOrgCode') )
. ")"
. $bib->subfield( '999', 'c' ) . ": "
. $cite;
$marcrecordauth->insert_fields_ordered(
MARC::Field->new( '670', '', '', 'a' => $cite ) );
$marcrecordauth->insert_fields_ordered( MARC::Field->new( '670', '', '', 'a' => $cite ) );
}
# warn "AUTH RECORD ADDED : ".$marcrecordauth->as_formatted;
$authid =
C4::AuthoritiesMarc::AddAuthority( $marcrecordauth, '',
$heading->auth_type() );
$authid = C4::AuthoritiesMarc::AddAuthority(
$marcrecordauth, '',
$heading->auth_type()
);
$field->add_subfields( '9', $authid );
$num_headings_changed++;
$linker->update_cache( $heading, $authid );
$results{'added'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'CREATED'}) if $verbose;
push( @{ $results{'details'} }, { tag => $field->tag(), authid => $authid, status => 'CREATED' } )
if $verbose;
}
}
elsif ( defined $current_link ) {
} elsif ( defined $current_link ) {
if ( _check_valid_auth_link( $current_link, $field ) ) {
$results{'linked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'UNCHANGED'}) if $verbose;
}
else {
push( @{ $results{'details'} }, { tag => $field->tag(), authid => $authid, status => 'UNCHANGED' } )
if $verbose;
} else {
$field->delete_subfield( code => '9' );
$num_headings_changed++;
$results{'unlinked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'NONE_FOUND', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
push(
@{ $results{'details'} },
{
tag => $field->tag(), authid => undef, status => 'NONE_FOUND',
auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report
}
) if $verbose;
}
elsif ( $match_count > 1 ) {
} elsif ( $match_count > 1 ) {
$results{'unlinked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'MULTIPLE_MATCH', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
push(
@{ $results{'details'} },
{
tag => $field->tag(), authid => undef, status => 'MULTIPLE_MATCH',
auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report
}
else {
) if $verbose;
} else {
$results{'unlinked'}->{ $heading->display_form() }++;
push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'NONE_FOUND', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
push(
@{ $results{'details'} },
{
tag => $field->tag(), authid => undef, status => 'NONE_FOUND',
auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report
}
) if $verbose;
}
}
@ -933,11 +958,13 @@ sub GetISBDView {
if ( $fieldvalue > 0 ) {
my $hasputtextbefore = 0;
my @fieldslist = $record->field($fieldvalue);
@fieldslist = sort { $a->subfield($holdingbrtagsubf) cmp $b->subfield($holdingbrtagsubf) } @fieldslist if ( $fieldvalue eq $holdingbrtagf );
@fieldslist = sort { $a->subfield($holdingbrtagsubf) cmp $b->subfield($holdingbrtagsubf) } @fieldslist
if ( $fieldvalue eq $holdingbrtagf );
# warn "ERROR IN ISBD DEFINITION at : $isbdfield" unless $fieldvalue;
# warn "FV : $fieldvalue";
if ( $subfvalue ne "" ) {
# OPAC hidden subfield
next
if ( ( $template eq 'opac' )
@ -951,7 +978,9 @@ sub GetISBDView {
my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subfvalue, $subfield, '', $tagslib );
my $tagsubf = $tag . $subfvalue;
$calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
if ( $template eq "opac" ) {
$calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g;
}
# field builded, store the result
if ( $calculated && !$hasputtextbefore ) { # put textbefore if not done
@ -977,11 +1006,13 @@ sub GetISBDView {
for my $i ( 0 .. $#subf ) {
my $valuecode = $subf[$i][1];
my $subfieldcode = $subf[$i][0];
# OPAC hidden subfield
next
if ( ( $template eq 'opac' )
&& ( $tagslib->{$fieldvalue}->{$subfieldcode}->{'hidden'} || 0 ) > 0 );
my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subf[$i][0], $subf[$i][1], '', $tagslib );
my $subfieldvalue =
GetAuthorisedValueDesc( $tag, $subf[$i][0], $subf[$i][1], '', $tagslib );
my $tagsubf = $tag . $subfieldcode;
$calculated =~ s/ # replace all {{}} codes by the value code.
@ -991,7 +1022,9 @@ sub GetISBDView {
/gx;
$calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
if ( $template eq "opac" ) {
$calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g;
}
}
# field builded, store the result
@ -1080,9 +1113,15 @@ sub GetMarcStructure {
ORDER BY tagfield"
);
$sth->execute($frameworkcode);
my ( $liblibrarian, $libopac, $tag, $res, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue );
my (
$liblibrarian, $libopac, $tag, $res, $mandatory, $repeatable, $important, $ind1_defaultvalue,
$ind2_defaultvalue
);
while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue ) = $sth->fetchrow ) {
while (
( $tag, $liblibrarian, $libopac, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue )
= $sth->fetchrow )
{
$res->{$tag}->{lib} = ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
$res->{$tag}->{tab} = "";
$res->{$tag}->{mandatory} = $mandatory;
@ -1184,15 +1223,19 @@ sub GetMarcSubfieldStructure {
return $cached if $cached;
my $dbh = C4::Context->dbh;
# We moved to selectall_arrayref since selectall_hashref does not
# keep duplicate mappings on kohafield (like place in 260 vs 264)
my $subfield_aref = $dbh->selectall_arrayref( q|
my $subfield_aref = $dbh->selectall_arrayref(
q|
SELECT *
FROM marc_subfield_structure
WHERE frameworkcode = ?
AND kohafield > ''
ORDER BY frameworkcode, tagfield, display_order, tagsubfield
|, { Slice => {} }, $frameworkcode );
|, { Slice => {} }, $frameworkcode
);
# Now map the output to a hash structure
my $subfield_structure = {};
foreach my $row (@$subfield_aref) {
@ -1317,6 +1360,7 @@ sub GetMarcPrice {
for my $field ( $record->field(@listtags) ) {
for my $subfield_value ( $field->subfield($subfield) ) {
#check value
$subfield_value = MungeMarcPrice($subfield_value);
return $subfield_value if ($subfield_value);
@ -1340,8 +1384,10 @@ sub MungeMarcPrice {
my $isocode = $active_currency->isocode;
$isocode = $active_currency->currency unless defined $isocode;
my $localprice;
if ($symbol) {
my @matches =($price=~ /
my @matches = (
$price =~ /
\s?
( # start of capturing parenthesis
(?:
@ -1356,7 +1402,8 @@ sub MungeMarcPrice {
\s?\p{L}{0,4}\s? # followed or not by a whitespace. \p{L}{0,4}\s? are for cases like '$9.50 USD'
) # end of capturing parenthesis
(?:\p{P}|\z) # followed by a punctuation sign or by the end of the string
/gx);
/gx
);
if (@matches) {
foreach (@matches) {
@ -1375,16 +1422,18 @@ sub MungeMarcPrice {
## Grab the first number in the string ( can use commas or periods for thousands separator and/or decimal separator )
($price) = $price =~ m/([\d\,\.]+[[\,\.]\d\d]?)/;
}
# eliminate symbol/isocode, space and any final dot from the string
$price =~ s/[\p{Sc}\p{L}\/ ]|\.$//g;
# remove comma,dot when used as separators from hundreds
$price =~ s/[\,\.](\d{3})/$1/g;
# convert comma to dot to ensure correct display of decimals if existing
$price =~ s/,/./;
return $price;
}
=head2 GetMarcQuantity
return the quantity of a book. Used in acquisition only, when importing a file an iso2709 from a bookseller
@ -1407,7 +1456,7 @@ sub GetMarcQuantity {
my $subfield;
if ( $marcflavour eq "MARC21" ) {
return 0
return 0;
} elsif ( $marcflavour eq "UNIMARC" ) {
@listtags = ('969');
$subfield = "a";
@ -1417,8 +1466,10 @@ sub GetMarcQuantity {
for my $field ( $record->field(@listtags) ) {
for my $subfield_value ( $field->subfield($subfield) ) {
#check value
if ($subfield_value) {
# in France, the cents separator is the , but sometimes, ppl use a .
# in this case, the price will be x100 when unformatted ! Replace the . by a , to get a proper price calculation
$subfield_value =~ s/\./,/ if C4::Context->preference("CurrencyFormat") eq "FR";
@ -1429,7 +1480,6 @@ sub GetMarcQuantity {
return 0; # no price found
}
=head2 GetAuthorisedValueDesc
my $subfieldvalue =get_authorised_value_desc(
@ -1464,10 +1514,10 @@ sub GetAuthorisedValueDesc {
my $libraries = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
if ( !$libraries ) {
$libraries = {
map { $_->branchcode => $_->branchname }
Koha::Libraries->search( {},
{ columns => [ 'branchcode', 'branchname' ] } )
->as_list
map { $_->branchcode => $_->branchname } Koha::Libraries->search(
{},
{ columns => [ 'branchcode', 'branchname' ] }
)->as_list
};
$cache->set_in_cache( $cache_key, $libraries );
}
@ -1481,9 +1531,7 @@ sub GetAuthorisedValueDesc {
$cache_key = 'itemtype:description:' . $lang;
my $itypes = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
if ( !$itypes ) {
$itypes =
{ map { $_->itemtype => $_->translated_description }
Koha::ItemTypes->search()->as_list };
$itypes = { map { $_->itemtype => $_->translated_description } Koha::ItemTypes->search()->as_list };
$cache->set_in_cache( $cache_key, $itypes );
}
return $itypes->{$value};
@ -1494,10 +1542,10 @@ sub GetAuthorisedValueDesc {
my $cn_sources = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
if ( !$cn_sources ) {
$cn_sources = {
map { $_->cn_source => $_->description }
Koha::ClassSources->search( {},
{ columns => [ 'cn_source', 'description' ] } )
->as_list
map { $_->cn_source => $_->description } Koha::ClassSources->search(
{},
{ columns => [ 'cn_source', 'description' ] }
)->as_list
};
$cache->set_in_cache( $cache_key, $cn_sources );
}
@ -1514,14 +1562,10 @@ sub GetAuthorisedValueDesc {
my $av_descriptions = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
if ( !$av_descriptions ) {
$av_descriptions = {
map {
$_->authorised_value =>
{ lib => $_->lib, lib_opac => $_->lib_opac }
} Koha::AuthorisedValues->search(
map { $_->authorised_value => { lib => $_->lib, lib_opac => $_->lib_opac } }
Koha::AuthorisedValues->search(
{ category => $category },
{
columns => [ 'authorised_value', 'lib_opac', 'lib' ]
}
{ columns => [ 'authorised_value', 'lib_opac', 'lib' ] }
)->as_list
};
$cache->set_in_cache( $cache_key, $av_descriptions );
@ -1567,7 +1611,6 @@ sub GetMarcISBN {
return \@marcisbns;
} # end GetMarcISBN
=head2 GetMarcISSN
$marcissnsarray = GetMarcISSN( $record, $marcflavour );
@ -1586,8 +1629,7 @@ sub GetMarcISSN {
my $scope;
if ( $marcflavour eq "UNIMARC" ) {
$scope = '011';
}
else { # assume MARC21
} else { # assume MARC21
$scope = '022';
}
my @marcissns;
@ -1642,7 +1684,7 @@ sub GetMarcSubjects {
my $linkvalue = $subfield9;
$linkvalue =~ s/(\(|\))//g;
@link_loop = ( { limit => 'an', 'link' => $linkvalue } );
$authoritylink = $linkvalue
$authoritylink = $linkvalue;
}
# other subfields
@ -1651,6 +1693,7 @@ sub GetMarcSubjects {
# don't load unimarc subfields 3,4,5
next if ( ( $marcflavour eq "UNIMARC" ) and ( $subject_subfield->[0] =~ /2|3|4|5/ ) );
# don't load MARC21 subfields 2 (FIXME: any more subfields??)
next if ( ( $marcflavour eq "MARC21" ) and ( $subject_subfield->[0] =~ /2/ ) );
@ -1658,6 +1701,7 @@ sub GetMarcSubjects {
my $value = $subject_subfield->[1];
my $linkvalue = $value;
$linkvalue =~ s/(\(|\))//g;
# if no authority link, build a search query
unless ($subfield9) {
push @link_loop, {
@ -1667,6 +1711,7 @@ sub GetMarcSubjects {
};
}
my @this_link_loop = @link_loop;
# do not display $0
unless ( $code eq '0' ) {
push @subfields_loop, {
@ -1813,7 +1858,7 @@ sub GetMarcSeries {
link_loop => \@link_loop,
separator => ( scalar @subfields_loop ) ? $AuthoritySeparator : '',
volumenum => $volume_number,
}
};
}
}
push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
@ -1834,8 +1879,7 @@ sub UpsertMarcSubfield {
if ($f) {
$f->update( $code => $content );
}
else {
} else {
my $f = MARC::Field->new( $tag, '', '', $code => $content );
$record->insert_fields_ordered($f);
}
@ -1854,8 +1898,7 @@ sub UpsertMarcControlField {
if ($f) {
$f->update($content);
}
else {
} else {
my $f = MARC::Field->new( $tag, $content );
$record->insert_fields_ordered($f);
}
@ -1876,7 +1919,8 @@ sub GetFrameworkCode {
my $dbh = C4::Context->dbh;
($frameworkcode) = $dbh->selectrow_array(
"SELECT frameworkcode FROM biblio WHERE biblionumber=?",
undef, $biblionumber );
undef, $biblionumber
);
$cache->set_in_cache( $cache_key, $frameworkcode );
}
return $frameworkcode;
@ -1895,7 +1939,6 @@ entry from user entry.
=cut
sub TransformKohaToMarc {
my ( $hash, $params ) = @_;
my $record = MARC::Record->new();
@ -1912,7 +1955,8 @@ sub TransformKohaToMarc {
next if !$tagfield;
# BZ 21800: split value if field is repeatable.
my @values = _check_split($params, $fld, $value)
my @values =
_check_split( $params, $fld, $value )
? split( /\s?\|\s?/, $value, -1 )
: ($value);
foreach my $value (@values) {
@ -1926,6 +1970,7 @@ sub TransformKohaToMarc {
my @sfl = @{ $tag_hr->{$tag} };
@sfl = sort { $a->[0] cmp $b->[0]; } @sfl;
@sfl = map { @{$_}; } @sfl;
# Special care for control fields: remove the subfield indication @
# and do not insert indicators.
my @ind = $tag < 10 ? () : ( " ", " " );
@ -1936,6 +1981,7 @@ sub TransformKohaToMarc {
}
sub _check_split {
# Checks if $value must be split; may consult passed framework
my ( $params, $fld, $value ) = @_;
return if index( $value, '|' ) == -1; # nothing to worry about
@ -1989,7 +2035,6 @@ sub PrepHostMarcField {
$qualinfo = $field260->as_string('abc');
}
#other fields
my $ed = $hostrecord->subfield( '250', 'a' );
my $barcode = $item->barcode;
@ -2008,7 +2053,6 @@ sub PrepHostMarcField {
my $issn = $hostrecord->subfield( '022', 'a' );
my $isbn = $hostrecord->subfield( '020', 'a' );
$hostmarcfield = MARC::Field->new(
773, '0', '',
'0' => $hostbiblionumber,
@ -2029,7 +2073,7 @@ sub PrepHostMarcField {
't' => $hostrecord->subfield( '200', 'a' ),
'9' => $hostitemnumber
);
};
}
return $hostmarcfield;
}
@ -2055,6 +2099,7 @@ $auth_type contains :
sub TransformHtmlToXml {
my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
# NOTE: The parameter $ind_tag is NOT USED -- BZ 11247
my ( $perm_loc_tag, $perm_loc_subfield ) = C4::Biblio::GetMarcFromKohaField("items.permanent_location");
@ -2107,7 +2152,8 @@ sub TransformHtmlToXml {
if ( !$first ) {
$xml .= "</datafield>\n";
if ( ( @$tags[$i] && @$tags[$i] > 10 )
&& ( !$skip ) ) {
&& ( !$skip ) )
{
$xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
$xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
$first = 0;
@ -2232,6 +2278,7 @@ sub TransformHtmlToMarc {
my @fields;
my ( $biblionumbertagfield, $biblionumbertagsubfield ) = ( -1, -1 );
( $biblionumbertagfield, $biblionumbertagsubfield ) = &GetMarcFromKohaField("biblio.biblionumber") if $isbiblio;
#FIXME This code assumes that the CGI params will be in the same order as the fields in the template; this is no absolute guarantee!
for ( my $i = 0 ; $params[$i] ; $i++ ) { # browse all CGI params
my $param = $params[$i];
@ -2242,7 +2289,10 @@ sub TransformHtmlToMarc {
if ( $biblionumbertagfield < 10 ) {
$newfield = MARC::Field->new( $biblionumbertagfield, scalar $cgi->param($param), );
} else {
$newfield = MARC::Field->new( $biblionumbertagfield, '', '', "$biblionumbertagsubfield" => scalar $cgi->param($param), );
$newfield = MARC::Field->new(
$biblionumbertagfield, '', '',
"$biblionumbertagsubfield" => scalar $cgi->param($param),
);
}
push @fields, $newfield if ($newfield);
} elsif ( $param =~ /^tag_(\d*)_indicator1_/ ) { # new field start when having 'input name="..._indicator1_..."
@ -2258,14 +2308,15 @@ sub TransformHtmlToMarc {
next if $tag == $biblionumbertagfield;
my $fval = $cgi->param( $params[ $j + 1 ] );
if ( $tag eq '000' ) {
# Force a fake leader even if not provided to avoid crashing
# during decoding MARC record containing UTF-8 characters
$record->leader(
length($fval) == 24
? $fval
: ' nam a22 4500'
)
;
);
# between 001 and 009 (included)
} elsif ( $fval ne '' ) {
$fval = StripNonXmlChars($fval); #Strip out any non-XML characters like control characters
@ -2274,22 +2325,25 @@ sub TransformHtmlToMarc {
# > 009, deal with subfields
} else {
# browse subfields for this tag (reason for _code_ match)
while ( defined $params[$j] && $params[$j] =~ /_code_/ ) {
last unless defined $params[ $j + 1 ];
$j += 2 and next
if $tag == $biblionumbertagfield and
$cgi->param($params[$j]) eq $biblionumbertagsubfield;
$j += 2
and next
if $tag == $biblionumbertagfield
and $cgi->param( $params[$j] ) eq $biblionumbertagsubfield;
#if next param ne subfield, then it was probably empty
#try next param by incrementing j
if ( $params[ $j + 1 ] !~ /_subfield_/ ) { $j++; next; }
my $fkey = $cgi->param( $params[$j] );
my $fval = $cgi->param( $params[ $j + 1 ] );
#check if subfield value not empty and field exists
if ( $fval ne '' && $newfield ) {
$newfield->add_subfields( $fkey => $fval );
}
elsif($fval ne '') {
} elsif ( $fval ne '' ) {
$fval = StripNonXmlChars($fval); #Strip out any non-XML characters like control characters
$newfield = MARC::Field->new( $tag, $ind1, $ind2, $fkey => $fval );
}
@ -2420,12 +2474,14 @@ sub _disambiguate {
sub _adjust_pubyear {
my $retval = shift;
# modify return value to keep only the 1st year found
if ( $retval =~ m/c(\d\d\d\d)/ and $1 > 0 ) { # search cYYYY first
$retval = $1;
} elsif ( $retval =~ m/(\d\d\d\d)/ && $1 > 0 ) {
$retval = $1;
} elsif ( $retval =~ m/(?<year>\d{1,3})[.Xx?-]/ ) {
# See also bug 24674: enough to look at one unknown year char like .Xx-?
# At this point in code 1234? or 1234- already passed the earlier regex
# Things like 2-, 1xx, 1??? are now converted to a four positions-year.
@ -2445,7 +2501,9 @@ sub _adjust_pubyear {
sub CountItemsIssued {
my ($biblionumber) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare('SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?');
my $sth = $dbh->prepare(
'SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?'
);
$sth->execute($biblionumber);
my $row = $sth->fetchrow_hashref();
return $row->{'issuedCount'};
@ -2544,7 +2602,8 @@ sub _koha_marc_update_biblioitem_cn_sort {
my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField("biblioitems.cn_sort");
return unless $biblioitem_tag;
my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
my ($cn_sort) =
GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
if ( my $field = $marc->field($biblioitem_tag) ) {
$field->delete_subfield( code => $biblioitem_subfield );
@ -2557,7 +2616,8 @@ sub _koha_marc_update_biblioitem_cn_sort {
# we'll create it if $cn_sort is not empty -- this would be
# an odd combination of events, however
if ($cn_sort) {
$marc->insert_grouped_field( MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
$marc->insert_grouped_field(
MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
}
}
}
@ -2597,7 +2657,8 @@ sub _koha_modify_biblio {
$sth->execute(
$frameworkcode, $biblio->{'author'}, $biblio->{'title'}, $biblio->{'subtitle'},
$biblio->{'medium'}, $biblio->{'part_number'}, $biblio->{'part_name'}, $biblio->{'unititle'},
$biblio->{'notes'}, $biblio->{'serial'}, $biblio->{'seriestitle'}, $biblio->{'copyrightdate'} ? int($biblio->{'copyrightdate'}) : undef,
$biblio->{'notes'}, $biblio->{'serial'}, $biblio->{'seriestitle'},
$biblio->{'copyrightdate'} ? int( $biblio->{'copyrightdate'} ) : undef,
$biblio->{'abstract'}, $biblio->{'biblionumber'}
) if $biblio->{'biblionumber'};
@ -2622,7 +2683,8 @@ sub _koha_modify_biblioitem_nonmarc {
my $error;
# re-calculate the cn_sort, it may have changed
my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
my ($cn_sort) =
GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
my $query = "UPDATE biblioitems
SET biblionumber = ?,
@ -2661,8 +2723,10 @@ sub _koha_modify_biblioitem_nonmarc {
$sth->execute(
$biblioitem->{'biblionumber'}, $biblioitem->{'volume'}, $biblioitem->{'number'}, $biblioitem->{'itemtype'},
$biblioitem->{'isbn'}, $biblioitem->{'issn'}, $biblioitem->{'publicationyear'}, $biblioitem->{'publishercode'},
$biblioitem->{'volumedate'}, $biblioitem->{'volumedesc'}, $biblioitem->{'collectiontitle'}, $biblioitem->{'collectionissn'},
$biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
$biblioitem->{'volumedate'}, $biblioitem->{'volumedesc'}, $biblioitem->{'collectiontitle'},
$biblioitem->{'collectionissn'},
$biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'},
$biblioitem->{'illus'},
$biblioitem->{'pages'}, $biblioitem->{'bnotes'}, $biblioitem->{'size'}, $biblioitem->{'place'},
$biblioitem->{'lccn'}, $biblioitem->{'url'}, $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'},
$biblioitem->{'cn_item'}, $biblioitem->{'cn_suffix'}, $cn_sort, $biblioitem->{'totalissues'},
@ -2720,6 +2784,7 @@ sub _koha_delete_biblio {
# delete the biblio
my $sth2 = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
$sth2->execute($biblionumber);
# update the timestamp (Bugzilla 7146)
$sth2 = $dbh->prepare("UPDATE deletedbiblio SET timestamp=NOW() WHERE biblionumber=?");
$sth2->execute($biblionumber);
@ -2769,6 +2834,7 @@ sub _koha_delete_biblioitems {
# delete the biblioitem
my $sth2 = $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
$sth2->execute($biblioitemnumber);
# update the timestamp (Bugzilla 7146)
$sth2 = $dbh->prepare("UPDATE deletedbiblioitems SET timestamp=NOW() WHERE biblioitemnumber=?");
$sth2->execute($biblioitemnumber);
@ -2793,12 +2859,16 @@ sub _koha_delete_biblio_metadata {
my $schema = Koha::Database->new->schema;
$schema->txn_do(
sub {
$dbh->do( q|
$dbh->do(
q|
INSERT INTO deletedbiblio_metadata (biblionumber, format, `schema`, metadata)
SELECT biblionumber, format, `schema`, metadata FROM biblio_metadata WHERE biblionumber=?
|, undef, $biblionumber );
$dbh->do( q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
undef, $biblionumber );
|, undef, $biblionumber
);
$dbh->do(
q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
undef, $biblionumber
);
}
);
}
@ -2826,6 +2896,7 @@ The C<$options> argument is a hashref with additional parameters:
=cut
sub ModBiblioMarc {
# pass the MARC::Record to this function, and it will create the records in
# the marcxml field
my ( $record, $biblionumber, $options ) = @_;
@ -2881,16 +2952,21 @@ sub ModBiblioMarc {
};
$record->as_usmarc; # Bug 20126/10455 This triggers field length calculation
my $m_rs = Koha::Biblio::Metadatas->find($metadata) //
Koha::Biblio::Metadata->new($metadata);
my $m_rs = Koha::Biblio::Metadatas->find($metadata) // Koha::Biblio::Metadata->new($metadata);
my $userenv = C4::Context->userenv;
if ($userenv) {
my $borrowernumber = $userenv->{number};
my $borrowername = join ' ', map { $_ // q{} } @$userenv{qw(firstname surname)};
unless ( $m_rs->in_storage ) {
Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorId'), $borrowernumber);
Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorName'), $borrowername);
Koha::Util::MARC::set_marc_field(
$record, C4::Context->preference('MarcFieldForCreatorId'),
$borrowernumber
);
Koha::Util::MARC::set_marc_field(
$record, C4::Context->preference('MarcFieldForCreatorName'),
$borrowername
);
}
Koha::Util::MARC::set_marc_field( $record, C4::Context->preference('MarcFieldForModifierId'), $borrowernumber );
Koha::Util::MARC::set_marc_field( $record, C4::Context->preference('MarcFieldForModifierName'), $borrowername );
@ -2933,6 +3009,7 @@ sub prepare_host_field {
my $biblio = Koha::Biblios->find($hostbiblio);
my $host = $biblio->metadata->record;
# unfortunately as_string does not 'do the right thing'
# if field returns undef
my %sfd;
@ -2980,8 +3057,8 @@ sub prepare_host_field {
}
$host_field = MARC::Field->new( 773, '0', ' ', %sfd );
return $host_field;
}
elsif ( $marcflavour eq 'UNIMARC' ) {
} elsif ( $marcflavour eq 'UNIMARC' ) {
#author
if ( $field = $host->field('700') || $host->field('710') || $host->field('720') ) {
my $s = $field->as_string('ab');
@ -2989,6 +3066,7 @@ sub prepare_host_field {
$sfd{a} = $s;
}
}
#title
if ( $field = $host->field('200') ) {
my $s = $field->as_string('a');
@ -2996,6 +3074,7 @@ sub prepare_host_field {
$sfd{t} = $s;
}
}
#place of publicaton
if ( $field = $host->field('210') ) {
my $s = $field->as_string('a');
@ -3003,6 +3082,7 @@ sub prepare_host_field {
$sfd{c} = $s;
}
}
#date of publication
if ( $field = $host->field('210') ) {
my $s = $field->as_string('d');
@ -3010,6 +3090,7 @@ sub prepare_host_field {
$sfd{d} = $s;
}
}
#edition statement
if ( $field = $host->field('205') ) {
my $s = $field->as_string();
@ -3017,6 +3098,7 @@ sub prepare_host_field {
$sfd{e} = $s;
}
}
#URL
if ( $field = $host->field('856') ) {
my $s = $field->as_string('u');
@ -3024,6 +3106,7 @@ sub prepare_host_field {
$sfd{u} = $s;
}
}
#ISSN
if ( $field = $host->field('011') ) {
my $s = $field->as_string('a');
@ -3031,6 +3114,7 @@ sub prepare_host_field {
$sfd{x} = $s;
}
}
#ISBN
if ( $field = $host->field('010') ) {
my $s = $field->as_string('a');
@ -3047,7 +3131,6 @@ sub prepare_host_field {
return;
}
=head2 UpdateTotalIssues
UpdateTotalIssues($biblionumber, $increase, [$value])
@ -3105,8 +3188,10 @@ sub UpdateTotalIssues {
if ( defined $field ) {
$field->update( $totalissuessubfield => $totalissues );
} else {
$field = MARC::Field->new($totalissuestag, '0', '0',
$totalissuessubfield => $totalissues);
$field = MARC::Field->new(
$totalissuestag, '0', '0',
$totalissuessubfield => $totalissues
);
$record->insert_grouped_field($field);
}
@ -3243,6 +3328,7 @@ sub _after_biblio_action_hooks {
biblio => $biblio,
biblio_id => $biblio_id,
},
# NOTE: Deprecate these duplicate params for 24.11.00
biblio => $biblio,
biblio_id => $biblio_id,

122
C4/Breeding.pm
View File

@ -33,6 +33,7 @@ use Koha::Database;
use Koha::XSLT::Base;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -94,6 +95,7 @@ sub BreedingSearch {
$sth->execute(@bind);
while ( my $data = $sth->fetchrow_hashref ) {
$results[$count] = $data;
# FIXME - hack to reflect difference in name
# of columns in old marc_breeding and import_records
# There needs to be more separation between column names and
@ -107,7 +109,6 @@ sub BreedingSearch {
return ( $count, @results );
} # sub breedingsearch
=head2 Z3950Search
Z3950Search($pars, $template);
@ -151,10 +152,9 @@ sub Z3950Search {
}
$oConnection[$s] = _create_connection($server);
$oResult[$s] =
$server->{servertype} eq 'zed'?
$oConnection[$s]->search_pqf( $server_zquery ):
$oConnection[$s]->search(ZOOM::Query::CQL->new(
_translate_query( $server, $squery )));
$server->{servertype} eq 'zed'
? $oConnection[$s]->search_pqf($server_zquery)
: $oConnection[$s]->search( ZOOM::Query::CQL->new( _translate_query( $server, $squery ) ) );
$s++;
}
my $xslh = Koha::XSLT::Base->new;
@ -175,23 +175,35 @@ sub Z3950Search {
if ( $error =~ m/^(10000|10007)$/ ) {
push( @errconn, { server => $servers[$k]->{host}, error => $error } );
}
}
else {
} else {
my $numresults = $oResult[$k]->size();
my $i;
my $res;
if ( $numresults > 0 and $numresults >= ( ( $page - 1 ) * 20 ) ) {
$show_next = 1 if $numresults >= ( $page * 20 );
$total_pages = int( $numresults / 20 ) + 1 if $total_pages < ( $numresults / 20 );
for ($i = ($page-1)*20; $i < (($numresults < ($page*20)) ? $numresults : ($page*20)); $i++) {
for (
$i = ( $page - 1 ) * 20 ;
$i < ( ( $numresults < ( $page * 20 ) ) ? $numresults : ( $page * 20 ) ) ;
$i++
)
{
if ( $oResult[$k]->record($i) ) {
undef $error;
( $res, $error ) = _handle_one_result( $oResult[$k]->record($i), $servers[$k], ++$imported, $biblionumber, $xslh ); #ignores error in sequence numbering
( $res, $error ) = _handle_one_result(
$oResult[$k]->record($i), $servers[$k], ++$imported, $biblionumber,
$xslh
); #ignores error in sequence numbering
push @breeding_loop, $res if $res;
push @errconn, { server => $servers[$k]->{servername}, error => $error, seq => $i+1 } if $error;
}
else {
push @errconn, { 'server' => $servers[$k]->{servername}, error => ( ( $oConnection[$k]->error_x() )[0] ), error_msg => ( ( $oConnection[$k]->error_x() )[1] ), seq => $i+1 };
push @errconn, { server => $servers[$k]->{servername}, error => $error, seq => $i + 1 }
if $error;
} else {
push @errconn,
{
'server' => $servers[$k]->{servername},
error => ( ( $oConnection[$k]->error_x() )[0] ),
error_msg => ( ( $oConnection[$k]->error_x() )[1] ), seq => $i + 1
};
}
}
} #if $numresults
@ -251,8 +263,7 @@ sub _bib_build_query {
author => '@attr 1=1003 "#term" ',
dewey => '@attr 1=16 "#term" ',
subject => '@attr 1=21 "#term" ',
lccall => '@attr 1=16 @attr 2=3 @attr 3=1 @attr 4=1 @attr 5=1 '.
'@attr 6=1 "#term" ',
lccall => '@attr 1=16 @attr 2=3 @attr 3=1 @attr 4=1 @attr 5=1 ' . '@attr 6=1 "#term" ',
controlnumber => '@attr 1=12 "#term" ',
srchany => '@attr 1=1016 "#term" ',
stdid => '@attr 1=1007 "#term" ',
@ -270,6 +281,7 @@ sub _build_query {
my $squery = '';
my $nterms = 0;
foreach my $k ( sort keys %$pars ) {
#note that the sort keys forces an identical result under Perl 5.18
#one of the unit tests is based on that assumption
if ( ( my $val = $pars->{$k} ) && $qry_build->{$k} ) {
@ -290,11 +302,15 @@ sub _handle_one_result {
my $raw = $zoomrec->raw();
my $marcrecord;
if ( $servhref->{servertype} eq 'sru' ) {
$marcrecord= MARC::Record->new_from_xml( $raw, 'UTF-8',
$servhref->{syntax} );
$marcrecord = MARC::Record->new_from_xml(
$raw, 'UTF-8',
$servhref->{syntax}
);
$marcrecord->encoding('UTF-8');
} else {
($marcrecord) = MarcToUTF8Record($raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" ); #ignores charset return values
($marcrecord) =
MarcToUTF8Record( $raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" )
; #ignores charset return values
}
SetUTF8Flag($marcrecord);
my $error;
@ -302,13 +318,17 @@ sub _handle_one_result {
my $batch_id = GetZ3950BatchId( $servhref->{servername} );
my $breedingid = AddBiblioToBatch( $batch_id, $seq, $marcrecord, 'UTF-8', 0 );
#Last zero indicates: no update for batch record counts
my $row;
if ($breedingid) {
my @kohafields = ('biblio.title','biblio.author','biblioitems.isbn','biblioitems.lccn','biblioitems.editionstatement');
push @kohafields, C4::Context->preference('marcflavour') eq "MARC21" ? 'biblio.copyrightdate' : 'biblioitems.publicationyear';
$row = C4::Biblio::TransformMarcToKoha({ record => $marcrecord, kohafields => \@kohafields, limit_table => 'no_items' });
my @kohafields =
( 'biblio.title', 'biblio.author', 'biblioitems.isbn', 'biblioitems.lccn', 'biblioitems.editionstatement' );
push @kohafields,
C4::Context->preference('marcflavour') eq "MARC21" ? 'biblio.copyrightdate' : 'biblioitems.publicationyear';
$row = C4::Biblio::TransformMarcToKoha(
{ record => $marcrecord, kohafields => \@kohafields, limit_table => 'no_items' } );
$row->{date} = $row->{copyrightdate} // $row->{publicationyear};
$row->{biblionumber} = $bib;
$row->{server} = $servhref->{servername};
@ -331,9 +351,10 @@ sub _do_xslt_proc {
my @files = split ',', $server->{add_xslt};
my $xml = $marc->as_xml;
foreach my $f (@files) {
$f =~ s/^\s+//; $f =~ s/\s+$//; next if !$f;
$f = C4::XSLT::_get_best_default_xslt_filename(
$htdocs, $theme, $lang, $f ) unless $f =~ /^\//;
$f =~ s/^\s+//;
$f =~ s/\s+$//;
next if !$f;
$f = C4::XSLT::_get_best_default_xslt_filename( $htdocs, $theme, $lang, $f ) unless $f =~ /^\//;
$xml = $xslh->transform( $xml, $f );
last if $xslh->err; #skip other files
}
@ -344,8 +365,7 @@ sub _do_xslt_proc {
}
}
sub _add_custom_field_rowdata
{
sub _add_custom_field_rowdata {
my ( $row, $record, $pref_newtags ) = @_;
$pref_newtags //= '';
my $pref_flavour = C4::Context->preference('MarcFlavour');
@ -413,6 +433,7 @@ sub _create_connection {
if ( $server->{servertype} eq 'sru' ) {
foreach ( split ',', $server->{sru_options} // '' ) {
#first remove surrounding spaces at comma and equals-sign
s/^\s+|\s+$//g;
my @temp = split '=', $_, 2;
@ -428,6 +449,7 @@ sub _create_connection {
if ( $server->{servertype} eq 'sru' ) {
my $host = $server->{host};
if ( $host !~ /^https?:\/\// ) {
#Normally, host will not be prefixed by protocol.
#In that case we can (safely) assume http.
#In case someone prefixed with https, give it a try..
@ -446,7 +468,10 @@ sub _translate_query { #SRU query adjusted per server cf. srufields column
#sru_fields is in format title=field,isbn=field,...
#if a field doesn't exist, try anywhere or remove [field]=
my @parts = split( ',', $server->{sru_fields} );
my %trans= map { if( /=/ ) { ( $`,$' ) } else { () } } @parts;
my %trans = map {
if (/=/) { ( $`, $' ) }
else { () }
} @parts;
my $any = $trans{srchany} ? $trans{srchany} . '=' : '';
my $q = $query;
@ -475,7 +500,8 @@ sub ImportBreedingAuth {
my $dbh = C4::Context->dbh;
my $batch_id = GetZ3950BatchId($filename);
my $searchbreeding = $dbh->prepare("select import_record_id from import_auths where control_number=? and authorized_heading=?");
my $searchbreeding =
$dbh->prepare("select import_record_id from import_auths where control_number=? and authorized_heading=?");
my $controlnumber = $marcrecord->field('001')->data;
@ -506,7 +532,6 @@ sub Z3950SearchAuth {
my @id = @{ $pars->{id} };
my $page = $pars->{page} // 1;
my $show_next = 0;
my $total_pages = 0;
my @encoding;
@ -536,11 +561,9 @@ sub Z3950SearchAuth {
$server_zquery = "$attributes $zquery";
}
$oResult[$s] = $oConnection[$s]->search_pqf($server_zquery);
}
else {
$oResult[$s] = $oConnection[$s]->search(
ZOOM::Query::CQL->new(_translate_query( $server, $squery ))
);
} else {
$oResult[$s] =
$oConnection[$s]->search( ZOOM::Query::CQL->new( _translate_query( $server, $squery ) ) );
}
$encoding[$s] = ( $server->{encoding} ? $server->{encoding} : "iso-5426" );
$servers[$s] = $server;
@ -564,30 +587,39 @@ sub Z3950SearchAuth {
if ( $error =~ m/^(10000|10007)$/ ) {
push @errconn, { server => $servers[$k]->{host} };
}
}
else {
} else {
my $numresults = $oResult[$k]->size();
my $i;
my $result = '';
if ( $numresults > 0 and $numresults >= ( ( $page - 1 ) * 20 ) ) {
$show_next = 1 if $numresults >= ( $page * 20 );
$total_pages = int( $numresults / 20 ) + 1 if $total_pages < ( $numresults / 20 );
for ($i = ($page-1)*20; $i < (($numresults < ($page*20)) ? $numresults : ($page*20)); $i++) {
for (
$i = ( $page - 1 ) * 20 ;
$i < ( ( $numresults < ( $page * 20 ) ) ? $numresults : ( $page * 20 ) ) ;
$i++
)
{
my $rec = $oResult[$k]->record($i);
if ($rec) {
my $marcdata = $rec->raw();
my $marcrecord;
if ( $servers[$k]->{servertype} eq 'sru' ) {
$marcrecord = eval { MARC::Record->new_from_xml( $marcdata, 'UTF-8', $servers[$k]->{syntax} ) };
$marcrecord =
eval { MARC::Record->new_from_xml( $marcdata, 'UTF-8', $servers[$k]->{syntax} ) };
if ( !$marcrecord || $@ ) {
_dump_conversion_error( $servers[$k]->{servername}, $marcdata, $@ );
next; # skip this one
}
} else {
my ( $charset_result, $charset_errors );
( $marcrecord, $charset_result, $charset_errors ) = MarcToUTF8Record( $marcdata, $marc_type, $encoding[$k] );
( $marcrecord, $charset_result, $charset_errors ) =
MarcToUTF8Record( $marcdata, $marc_type, $encoding[$k] );
if ( !$marcrecord || @$charset_errors ) {
_dump_conversion_error( $servers[$k]->{servername}, $marcdata, $charset_result, $charset_errors );
_dump_conversion_error(
$servers[$k]->{servername}, $marcdata, $charset_result,
$charset_errors
);
next; # skip this one
}
}
@ -608,9 +640,15 @@ sub Z3950SearchAuth {
C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch')
) if C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch');
push( @breeding_loop, \%row_data );
} else {
push(
@breeding_loop,
{
'server' => $servers[$k]->{'servername'},
'title' => join( ': ', $oConnection[$k]->error_x() ), 'breedingid' => -1,
'authid' => -1
}
else {
push(@breeding_loop,{'server'=>$servers[$k]->{'servername'},'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1,'authid'=>-1});
);
}
}
} #if $numresults

252
C4/Budgets.pm
View File

@ -27,6 +27,7 @@ use C4::Acquisition;
use C4::Log qw(logaction);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -100,6 +101,7 @@ sub HideCols {
AND authvalue = ? |
);
foreach my $authvalue (@hide_cols) {
# $sth1->{TraceLevel} = 3;
$sth1->execute( $authcat, $authvalue );
}
@ -120,7 +122,7 @@ sub GetCols {
$sth->execute( $authcat, $authvalue );
my $res = $sth->fetchrow_hashref;
return $res->{cnt} > 0 ? 0: 1
return $res->{cnt} > 0 ? 0 : 1;
}
@ -134,7 +136,7 @@ sub CheckBudgetParentPerm {
if ( $parent->{budget_owner_id} == $borrower_id ) {
return 1;
}
$depth--
$depth--;
}
return 0;
}
@ -147,6 +149,7 @@ sub AddBudgetPeriod {
my $resultset = Koha::Database->new()->schema->resultset('Aqbudgetperiod');
return $resultset->create($budgetperiod)->id;
}
# -------------------------------------------------------------------
sub GetPeriodsCount {
my $dbh = C4::Context->dbh;
@ -166,9 +169,11 @@ sub CheckBudgetParent {
my $parent_id_tmp = $new_parent_id;
# check new-parent is not a child (or a child's child ;)
my $sth = $dbh->prepare(qq|
my $sth = $dbh->prepare(
qq|
SELECT budget_parent_id FROM
aqbudgets where budget_id = ? | );
aqbudgets where budget_id = ? |
);
while (1) {
$sth->execute($parent_id_tmp);
my $res = $sth->fetchrow_hashref;
@ -186,9 +191,11 @@ sub CheckBudgetParent {
sub BudgetHasChildren {
my ($budget_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare(qq|
my $sth = $dbh->prepare(
qq|
SELECT count(*) as sum FROM aqbudgets
WHERE budget_parent_id = ? | );
WHERE budget_parent_id = ? |
);
$sth->execute($budget_id);
my $sum = $sth->fetchrow_hashref;
return $sum->{'sum'};
@ -197,10 +204,12 @@ sub BudgetHasChildren {
sub GetBudgetChildren {
my ($budget_id) = @_;
my $dbh = C4::Context->dbh;
return $dbh->selectall_arrayref(q|
return $dbh->selectall_arrayref(
q|
SELECT * FROM aqbudgets
WHERE budget_parent_id = ?
|, { Slice => {} }, $budget_id );
|, { Slice => {} }, $budget_id
);
}
sub SetOwnerToFundHierarchy {
@ -222,9 +231,11 @@ sub GetBudgetsPlanCell {
my $dbh = C4::Context->dbh;
my $roundsql = C4::Acquisition::get_rounding_sql(qq|ecost_tax_included|);
if ( $cell->{'authcat'} eq 'MONTHS' ) {
# get the actual amount
# FIXME we should consider quantity
$sth = $dbh->prepare( qq|
$sth = $dbh->prepare(
qq|
SELECT SUM(| . $roundsql . qq|) AS actual FROM aqorders
WHERE budget_id = ? AND
@ -232,34 +243,43 @@ sub GetBudgetsPlanCell {
);
$sth->execute( $cell->{'budget_id'} );
} elsif ( $cell->{'authcat'} eq 'BRANCHES' ) {
# get the actual amount
# FIXME we should consider quantity
$sth = $dbh->prepare( qq|
$sth = $dbh->prepare(
qq|
SELECT SUM(| . $roundsql . qq|) FROM aqorders
LEFT JOIN aqorders_items
ON (aqorders.ordernumber = aqorders_items.ordernumber)
LEFT JOIN items
ON (aqorders_items.itemnumber = items.itemnumber)
WHERE budget_id = ? AND homebranch = ? | );
WHERE budget_id = ? AND homebranch = ? |
);
$sth->execute( $cell->{'budget_id'}, $cell->{'authvalue'} );
} elsif ( $cell->{'authcat'} eq 'ITEMTYPES' ) {
# get the actual amount
$sth = $dbh->prepare( qq|
$sth = $dbh->prepare(
qq|
SELECT SUM( | . $roundsql . qq| * quantity) AS actual
FROM aqorders JOIN biblioitems
ON (biblioitems.biblionumber = aqorders.biblionumber )
WHERE aqorders.budget_id = ? and itemtype = ? |
);
$sth->execute( $cell->{'budget_id'},
$cell->{'authvalue'} );
$sth->execute(
$cell->{'budget_id'},
$cell->{'authvalue'}
);
}
# ELSE GENERIC ORDERS SORT1/SORT2 STAT COUNT.
else {
# get the actual amount
$sth = $dbh->prepare( qq|
$sth = $dbh->prepare(
qq|
SELECT SUM(| . $roundsql . qq| * quantity) AS actual
FROM aqorders
@ -268,7 +288,8 @@ sub GetBudgetsPlanCell {
((aqbudgets.sort1_authcat = ? AND sort1 =?) OR
(aqbudgets.sort2_authcat = ? AND sort2 =?)) |
);
$sth->execute( $cell->{'budget_id'},
$sth->execute(
$cell->{'budget_id'},
$budget->{'sort1_authcat'},
$cell->{'authvalue'},
$budget->{'sort2_authcat'},
@ -278,7 +299,8 @@ sub GetBudgetsPlanCell {
$actual = $sth->fetchrow_array;
# get the estimated amount
$sth = $dbh->prepare( qq|
$sth = $dbh->prepare(
qq|
SELECT estimated_amount AS estimated, display FROM aqbudgets_planning
WHERE budget_period_id = ? AND
@ -286,18 +308,18 @@ sub GetBudgetsPlanCell {
authvalue = ? AND
authcat = ? |
);
$sth->execute( $cell->{'budget_period_id'},
$sth->execute(
$cell->{'budget_period_id'},
$cell->{'budget_id'},
$cell->{'authvalue'},
$cell->{'authcat'},
);
my $res = $sth->fetchrow_hashref;
# my $display = $res->{'display'};
my $estimated = $res->{'estimated'};
return $actual, $estimated;
}
@ -307,18 +329,21 @@ sub ModBudgetPlan {
my $dbh = C4::Context->dbh;
foreach my $buds (@$budget_plan) {
my $lines = $buds->{lines};
my $sth = $dbh->prepare( qq|
my $sth = $dbh->prepare(
qq|
DELETE FROM aqbudgets_planning
WHERE budget_period_id = ? AND
budget_id = ? AND
authcat = ? |
);
#delete a aqplan line of cells, then insert new cells,
# these could be UPDATES rather than DEL/INSERTS...
$sth->execute( $budget_period_id, $lines->[0]{budget_id}, $authcat );
foreach my $cell (@$lines) {
my $sth = $dbh->prepare( qq|
my $sth = $dbh->prepare(
qq|
INSERT INTO aqbudgets_planning
SET budget_id = ?,
@ -346,26 +371,35 @@ sub GetBudgetSpent {
# Choose correct unitprice and ecost fields
my ( $unitprice_field, $ecost_field ) = FieldsForCalculatingFundValues();
my $sth = $dbh->prepare(qq|
SELECT SUM( | . C4::Acquisition::get_rounding_sql("COALESCE($unitprice_field, $ecost_field)") . qq| * quantity ) AS sum FROM aqorders
my $sth = $dbh->prepare(
qq|
SELECT SUM( |
. C4::Acquisition::get_rounding_sql("COALESCE($unitprice_field, $ecost_field)")
. qq| * quantity ) AS sum FROM aqorders
WHERE budget_id = ? AND
quantityreceived > 0 AND
datecancellationprinted IS NULL
|);
|
);
$sth->execute($budget_id);
my $sum = ( $sth->fetchrow_array || 0 ) + 0;
$sth = $dbh->prepare(qq|
$sth = $dbh->prepare(
qq|
SELECT SUM(shipmentcost) AS sum
FROM aqinvoices
WHERE shipmentcost_budgetid = ?
|);
|
);
$sth->execute($budget_id);
my ($shipmentcost_sum) = $sth->fetchrow_array;
$sum += ( $shipmentcost_sum || 0 ) + 0;
my $adjustments = Koha::Acquisition::Invoice::Adjustments->search({budget_id => $budget_id, closedate => { '!=' => undef } },{ join => 'invoiceid' });
my $adjustments = Koha::Acquisition::Invoice::Adjustments->search(
{ budget_id => $budget_id, closedate => { '!=' => undef } },
{ join => 'invoiceid' }
);
while ( my $adj = $adjustments->next ) {
$sum += $adj->adjustment;
}
@ -381,16 +415,19 @@ sub GetBudgetOrdered {
# Get correct unitprice and ecost prices as possible
my ( $unitprice_field, $ecost_field ) = FieldsForCalculatingFundValues();
my $sth = $dbh->prepare(qq|
my $sth = $dbh->prepare(
qq|
SELECT SUM(| . C4::Acquisition::get_rounding_sql(qq|$ecost_field|) . qq| * quantity) AS sum FROM aqorders
WHERE budget_id = ? AND
quantityreceived = 0 AND
datecancellationprinted IS NULL
|);
|
);
$sth->execute($budget_id);
my $sum = ( $sth->fetchrow_array || 0 ) + 0;
my $adjustments = Koha::Acquisition::Invoice::Adjustments->search({budget_id => $budget_id, encumber_open => 1, closedate => undef},{ join => 'invoiceid' });
my $adjustments = Koha::Acquisition::Invoice::Adjustments->search(
{ budget_id => $budget_id, encumber_open => 1, closedate => undef }, { join => 'invoiceid' } );
while ( my $adj = $adjustments->next ) {
$sum += $adj->adjustment;
}
@ -414,7 +451,8 @@ sub GetBudgetName {
SELECT budget_name
FROM aqbudgets
WHERE budget_id = ?
|);
|
);
$sth->execute($budget_id);
return $sth->fetchrow_array;
@ -430,6 +468,7 @@ Return the list of authcat for a given budget_period_id
sub GetBudgetAuthCats {
my ($budget_period_id) = shift;
# now, populate the auth_cats_loop used in the budget planning button
# we must retrieve all auth values used by at least one budget
my $dbh = C4::Context->dbh;
@ -452,11 +491,13 @@ sub GetBudgetPeriods {
$rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
return [ $rs->all ];
}
# -------------------------------------------------------------------
sub GetBudgetPeriod {
my ($budget_period_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare( qq|
my $sth = $dbh->prepare(
qq|
SELECT *
FROM aqbudgetperiods
WHERE budget_period_id=? |
@ -472,7 +513,8 @@ sub DelBudgetPeriod{
my $total = 0;
## get information about the record that will be deleted
my $sth = $dbh->prepare(qq|
my $sth = $dbh->prepare(
qq|
DELETE
FROM aqbudgetperiods
WHERE budget_period_id=? |
@ -503,11 +545,13 @@ sub GetBudgetHierarchy {
JOIN aqbudgetperiods USING (budget_period_id)|;
my @where_strings;
# show only period X if requested
if ($budget_period_id) {
push @where_strings, " aqbudgets.budget_period_id = ?";
push @bind_params, $budget_period_id;
}
# show only budgets owned by me, my branch or everyone
if ($owner) {
if ($branchcode) {
@ -529,6 +573,7 @@ sub GetBudgetHierarchy {
$sth->execute(@bind_params);
my %links;
# create hash with budget_id has key
while ( my $data = $sth->fetchrow_hashref ) {
$links{ $data->{'budget_id'} } = $data;
@ -542,9 +587,11 @@ sub GetBudgetHierarchy {
my $parent = $links{ $child->{'budget_parent_id'} };
if ($parent) {
unless ( $parent->{'children'} ) {
# init child arrayref
$parent->{'children'} = [];
}
# add as child
push @{ $parent->{'children'} }, $child;
}
@ -562,48 +609,63 @@ sub GetBudgetHierarchy {
my ( $unitprice_field, $ecost_field ) = FieldsForCalculatingFundValues();
if ( !$skiptotals ) {
# Get all the budgets totals in as few queries as possible
my $hr_budget_spent = $dbh->selectall_hashref(q|
my $hr_budget_spent = $dbh->selectall_hashref(
q|
SELECT aqorders.budget_id, aqbudgets.budget_parent_id,
SUM( | . C4::Acquisition::get_rounding_sql(qq|COALESCE($unitprice_field, $ecost_field)|) . q| * quantity ) AS budget_spent
SUM( |
. C4::Acquisition::get_rounding_sql(qq|COALESCE($unitprice_field, $ecost_field)|)
. q| * quantity ) AS budget_spent
FROM aqorders JOIN aqbudgets USING (budget_id)
WHERE quantityreceived > 0 AND datecancellationprinted IS NULL
GROUP BY budget_id, budget_parent_id
|, 'budget_id');
my $hr_budget_ordered = $dbh->selectall_hashref(q|
|, 'budget_id'
);
my $hr_budget_ordered = $dbh->selectall_hashref(
q|
SELECT aqorders.budget_id, aqbudgets.budget_parent_id,
SUM( | . C4::Acquisition::get_rounding_sql(qq|$ecost_field|) . q| * quantity) AS budget_ordered
FROM aqorders JOIN aqbudgets USING (budget_id)
WHERE quantityreceived = 0 AND datecancellationprinted IS NULL
GROUP BY budget_id, budget_parent_id
|, 'budget_id');
my $hr_budget_spent_shipment = $dbh->selectall_hashref(q|
|, 'budget_id'
);
my $hr_budget_spent_shipment = $dbh->selectall_hashref(
q|
SELECT shipmentcost_budgetid as budget_id,
SUM(shipmentcost) as shipmentcost
FROM aqinvoices
GROUP BY shipmentcost_budgetid
|, 'budget_id');
my $hr_budget_spent_adjustment = $dbh->selectall_hashref(q|
|, 'budget_id'
);
my $hr_budget_spent_adjustment = $dbh->selectall_hashref(
q|
SELECT budget_id,
SUM(adjustment) as adjustments
FROM aqinvoice_adjustments
JOIN aqinvoices USING (invoiceid)
WHERE closedate IS NOT NULL
GROUP BY budget_id
|, 'budget_id');
my $hr_budget_ordered_adjustment = $dbh->selectall_hashref(q|
|, 'budget_id'
);
my $hr_budget_ordered_adjustment = $dbh->selectall_hashref(
q|
SELECT budget_id,
SUM(adjustment) as adjustments
FROM aqinvoice_adjustments
JOIN aqinvoices USING (invoiceid)
WHERE closedate IS NULL AND encumber_open = 1
GROUP BY budget_id
|, 'budget_id');
|, 'budget_id'
);
foreach my $budget (@sort) {
if ( not defined $budget->{budget_parent_id} ) {
_recursiveAdd( $budget, undef, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered, $hr_budget_spent_adjustment, $hr_budget_ordered_adjustment );
_recursiveAdd(
$budget, undef, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered,
$hr_budget_spent_adjustment, $hr_budget_ordered_adjustment
);
}
}
}
@ -611,10 +673,16 @@ sub GetBudgetHierarchy {
}
sub _recursiveAdd {
my ($budget, $parent, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered, $hr_budget_spent_adjustment, $hr_budget_ordered_adjustment ) = @_;
my (
$budget, $parent, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered,
$hr_budget_spent_adjustment, $hr_budget_ordered_adjustment
) = @_;
foreach my $child ( @{ $budget->{children} } ) {
_recursiveAdd($child, $budget, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered, $hr_budget_spent_adjustment, $hr_budget_ordered_adjustment );
_recursiveAdd(
$child, $budget, $hr_budget_spent, $hr_budget_spent_shipment, $hr_budget_ordered,
$hr_budget_spent_adjustment, $hr_budget_ordered_adjustment
);
}
$budget->{budget_spent} += $hr_budget_spent->{ $budget->{budget_id} }->{budget_spent} || 0;
@ -712,6 +780,7 @@ sub DelBudget {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("delete from aqbudgets where budget_id=?");
my $rc = $sth->execute($budget_id);
# Log the deletion
if ( C4::Context->preference("AcquisitionLog") ) {
logaction(
@ -723,7 +792,6 @@ sub DelBudget {
return $rc;
}
# -------------------------------------------------------------------
=head2 GetBudget
@ -837,6 +905,7 @@ sub GetBudgetsByActivity {
}
return @results;
}
# --------------------------------------------------------------------
=head2 GetBudgetsReport
@ -873,8 +942,7 @@ sub GetBudgetsReport {
my $sth = $dbh->prepare($query);
if ( $activity && $activity ne '' ) {
$sth->execute($activity);
}
else{
} else {
$sth->execute;
}
my @results = ();
@ -921,11 +989,13 @@ Gets the total spent of the level and sublevels of $budget_id
sub GetBudgetHierarchySpent {
my ($budget_id) = @_;
my $dbh = C4::Context->dbh;
my $children_ids = $dbh->selectcol_arrayref(q|
my $children_ids = $dbh->selectcol_arrayref(
q|
SELECT budget_id
FROM aqbudgets
WHERE budget_parent_id = ?
|, {}, $budget_id );
|, {}, $budget_id
);
my $total_spent = GetBudgetSpent($budget_id);
for my $child_id (@$children_ids) {
@ -945,11 +1015,13 @@ Gets the total ordered of the level and sublevels of $budget_id
sub GetBudgetHierarchyOrdered {
my ($budget_id) = @_;
my $dbh = C4::Context->dbh;
my $children_ids = $dbh->selectcol_arrayref(q|
my $children_ids = $dbh->selectcol_arrayref(
q|
SELECT budget_id
FROM aqbudgets
WHERE budget_parent_id = ?
|, {}, $budget_id );
|, {}, $budget_id
);
my $total_ordered = GetBudgetOrdered($budget_id);
for my $child_id (@$children_ids) {
@ -999,7 +1071,7 @@ sub GetBudgetUsers {
my @borrowernumbers;
while ( my ($borrowernumber) = $sth->fetchrow_array ) {
push @borrowernumbers, $borrowernumber
push @borrowernumbers, $borrowernumber;
}
return @borrowernumbers;
@ -1049,14 +1121,18 @@ sub CanUserUseBudget {
return 0 unless ( $borrower and $budget );
if ( not defined $userflags ) {
$userflags = C4::Auth::getuserflags($borrower->{flags},
$borrower->{userid});
$userflags = C4::Auth::getuserflags(
$borrower->{flags},
$borrower->{userid}
);
}
unless ($userflags->{superlibrarian}
unless (
$userflags->{superlibrarian}
|| ( ref $userflags->{acquisition}
&& $userflags->{acquisition}->{budget_manage_all} )
|| (!ref $userflags->{acquisition} && $userflags->{acquisition}))
|| ( !ref $userflags->{acquisition} && $userflags->{acquisition} )
)
{
if ( not exists $userflags->{acquisition} ) {
return 0;
@ -1081,16 +1157,12 @@ sub CanUserUseBudget {
if (
(
$budget->{budget_owner_id}
and $budget->{budget_owner_id} !=
$borrower->{borrowernumber}
$budget->{budget_owner_id} and $budget->{budget_owner_id} != $borrower->{borrowernumber}
or not $budget->{budget_owner_id}
)
and ( 0 == grep { $borrower->{borrowernumber} == $_ }
@budget_users )
and ( 0 == grep { $borrower->{borrowernumber} == $_ } @budget_users )
and defined $budget->{budget_branchcode}
and $budget->{budget_branchcode} ne
C4::Context->userenv->{branch}
and $budget->{budget_branchcode} ne C4::Context->userenv->{branch}
)
{
return 0;
@ -1102,13 +1174,10 @@ sub CanUserUseBudget {
my @budget_users = GetBudgetUsers( $budget->{budget_id} );
if (
(
$budget->{budget_owner_id}
and $budget->{budget_owner_id} !=
$borrower->{borrowernumber}
$budget->{budget_owner_id} and $budget->{budget_owner_id} != $borrower->{borrowernumber}
or not $budget->{budget_owner_id}
)
and ( 0 == grep { $borrower->{borrowernumber} == $_ }
@budget_users )
and ( 0 == grep { $borrower->{borrowernumber} == $_ } @budget_users )
)
{
return 0;
@ -1134,21 +1203,26 @@ sub CanUserModifyBudget {
return 0 unless ( $borrower and $budget );
if ( not defined $userflags ) {
$userflags = C4::Auth::getuserflags($borrower->{flags},
$borrower->{userid});
$userflags = C4::Auth::getuserflags(
$borrower->{flags},
$borrower->{userid}
);
}
unless ($userflags->{superlibrarian}
unless (
$userflags->{superlibrarian}
|| ( ref $userflags->{acquisition}
&& $userflags->{acquisition}->{budget_manage_all} )
|| (!ref $userflags->{acquisition} && $userflags->{acquisition}))
|| ( !ref $userflags->{acquisition} && $userflags->{acquisition} )
)
{
if ( !CanUserUseBudget( $borrower, $budget, $userflags ) ) {
return 0;
}
if ( ref $userflags->{acquisition}
&& !$userflags->{acquisition}->{budget_modify}) {
&& !$userflags->{acquisition}->{budget_modify} )
{
return 0;
}
}
@ -1193,8 +1267,7 @@ sub CloneBudgetPeriod {
my $budget_period_description = $params->{budget_period_description};
my $amount_change_percentage = $params->{amount_change_percentage};
my $amount_change_round_increment = $params->{amount_change_round_increment};
my $mark_original_budget_as_inactive =
$params->{mark_original_budget_as_inactive} || 0;
my $mark_original_budget_as_inactive = $params->{mark_original_budget_as_inactive} || 0;
my $reset_all_budgets = $params->{reset_all_budgets} || 0;
my $budget_period = GetBudgetPeriod($budget_period_id);
@ -1202,6 +1275,7 @@ sub CloneBudgetPeriod {
$budget_period->{budget_period_startdate} = $budget_period_startdate;
$budget_period->{budget_period_enddate} = $budget_period_enddate;
$budget_period->{budget_period_description} = $budget_period_description;
# The new budget (budget_period) should be active by default
$budget_period->{budget_period_active} = 1;
@ -1281,13 +1355,12 @@ sub CloneBudgetHierarchy {
# get only the columns of aqbudgets
my @columns = Koha::Database->new()->schema->source('Aqbudget')->columns;
for my $budget ( sort { $a->{budget_id} <=> $b->{budget_id} }
@first_level_budgets )
{
for my $budget ( sort { $a->{budget_id} <=> $b->{budget_id} } @first_level_budgets ) {
my $tidy_budget =
{ map { join( ' ', @columns ) =~ /$_/ ? ( $_ => $budget->{$_} ) : () }
keys %$budget };
my $tidy_budget = {
map { join( ' ', @columns ) =~ /$_/ ? ( $_ => $budget->{$_} ) : () }
keys %$budget
};
delete $tidy_budget->{timestamp};
my $new_budget_id = AddBudget(
{
@ -1352,6 +1425,7 @@ sub MoveOrders {
|
);
my $from_budgets = GetBudgetHierarchy($from_budget_period_id);
for my $from_budget (@$from_budgets) {
my $new_budget_id = $dbh->selectcol_arrayref(
q|
@ -1395,8 +1469,10 @@ sub MoveOrders {
$unspent_moved = $unspent;
}
$new_budget->{budget_amount} = $new_budget_amount;
$sth_update_budget_amount->execute( $new_budget_amount,
$new_budget->{budget_id} );
$sth_update_budget_amount->execute(
$new_budget_amount,
$new_budget->{budget_id}
);
}
push @report,

108
C4/Calendar.pm
View File

@ -58,7 +58,8 @@ sub new {
foreach my $optionName ( keys %options ) {
$self->{ lc($optionName) } = $options{$optionName};
}
defined($self->{branchcode}) or croak "No branchcode argument to new. Should be C4::Calendar->new(branchcode => \$branchcode)";
defined( $self->{branchcode} )
or croak "No branchcode argument to new. Should be C4::Calendar->new(branchcode => \$branchcode)";
$self->_init( $self->{branchcode} );
return $self;
}
@ -68,12 +69,15 @@ sub _init {
my $branch = shift;
defined($branch) or die "No branchcode sent to _init"; # must test for defined here and above to allow ""
my $dbh = C4::Context->dbh();
my $repeatable = $dbh->prepare( 'SELECT *
my $repeatable = $dbh->prepare(
'SELECT *
FROM repeatable_holidays
WHERE ( branchcode = ? )
AND (ISNULL(weekday) = ?)' );
AND (ISNULL(weekday) = ?)'
);
$repeatable->execute( $branch, 0 );
my %week_days_holidays;
while ( my $row = $repeatable->fetchrow_hashref ) {
my $key = $row->{weekday};
$week_days_holidays{$key}{title} = $row->{title};
@ -92,10 +96,12 @@ sub _init {
}
$self->{'day_month_holidays'} = \%day_month_holidays;
my $special = $dbh->prepare( 'SELECT day, month, year, title, description
my $special = $dbh->prepare(
'SELECT day, month, year, title, description
FROM special_holidays
WHERE ( branchcode = ? )
AND (isexception = ?)' );
AND (isexception = ?)'
);
$special->execute( $branch, 1 );
my %exception_holidays;
while ( my ( $day, $month, $year, $title, $description ) = $special->fetchrow ) {
@ -201,7 +207,9 @@ sub insert_week_day_holiday {
croak "Invalid weekday $weekday" unless $weekday =~ m/^[0-6]$/;
my $dbh = C4::Context->dbh();
my $insertHoliday = $dbh->prepare("insert into repeatable_holidays (branchcode,weekday,day,month,title,description) values ( ?,?,NULL,NULL,?,? )");
my $insertHoliday = $dbh->prepare(
"insert into repeatable_holidays (branchcode,weekday,day,month,title,description) values ( ?,?,NULL,NULL,?,? )"
);
$insertHoliday->execute( $self->{branchcode}, $weekday, $options{title}, $options{description} );
$self->{'week_days_holidays'}->{$weekday}{title} = $options{title};
$self->{'week_days_holidays'}->{$weekday}{description} = $options{description};
@ -232,8 +240,13 @@ sub insert_day_month_holiday {
my %options = @_;
my $dbh = C4::Context->dbh();
my $insertHoliday = $dbh->prepare("insert into repeatable_holidays (branchcode,weekday,day,month,title,description) values (?, NULL, ?, ?, ?,? )");
$insertHoliday->execute( $self->{branchcode}, $options{day},$options{month},$options{title}, $options{description});
my $insertHoliday = $dbh->prepare(
"insert into repeatable_holidays (branchcode,weekday,day,month,title,description) values (?, NULL, ?, ?, ?,? )"
);
$insertHoliday->execute(
$self->{branchcode}, $options{day}, $options{month}, $options{title},
$options{description}
);
$self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{title} = $options{title};
$self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{description} = $options{description};
return $self;
@ -269,12 +282,16 @@ sub insert_single_holiday {
my $dbh = C4::Context->dbh();
my $isexception = 0;
my $insertHoliday = $dbh->prepare("insert into special_holidays (branchcode,day,month,year,isexception,title,description) values (?,?,?,?,?,?,?)");
$insertHoliday->execute( $self->{branchcode}, $options{day},$options{month},$options{year}, $isexception, $options{title}, $options{description});
my $insertHoliday = $dbh->prepare(
"insert into special_holidays (branchcode,day,month,year,isexception,title,description) values (?,?,?,?,?,?,?)"
);
$insertHoliday->execute(
$self->{branchcode}, $options{day}, $options{month}, $options{year}, $isexception,
$options{title}, $options{description}
);
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
# changed the 'single_holidays' table, lets force/reset its cache
my $cache = Koha::Caches->get_instance();
my $key = $self->{branchcode} . "_holidays";
@ -315,10 +332,16 @@ sub insert_exception_holiday {
my $dbh = C4::Context->dbh();
my $isexception = 1;
my $insertException = $dbh->prepare("insert into special_holidays (branchcode,day,month,year,isexception,title,description) values (?,?,?,?,?,?,?)");
$insertException->execute( $self->{branchcode}, $options{day},$options{month},$options{year}, $isexception, $options{title}, $options{description});
my $insertException = $dbh->prepare(
"insert into special_holidays (branchcode,day,month,year,isexception,title,description) values (?,?,?,?,?,?,?)"
);
$insertException->execute(
$self->{branchcode}, $options{day}, $options{month}, $options{year}, $isexception,
$options{title}, $options{description}
);
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} =
$options{description};
# changed the 'single_holidays' table, lets force/reset its cache
my $cache = Koha::Caches->get_instance();
@ -347,7 +370,8 @@ sub ModWeekdayholiday {
my %options = @_;
my $dbh = C4::Context->dbh();
my $updateHoliday = $dbh->prepare("UPDATE repeatable_holidays SET title = ?, description = ? WHERE branchcode = ? AND weekday = ?");
my $updateHoliday =
$dbh->prepare("UPDATE repeatable_holidays SET title = ?, description = ? WHERE branchcode = ? AND weekday = ?");
$updateHoliday->execute( $options{title}, $options{description}, $self->{branchcode}, $options{weekday} );
$self->{'week_days_holidays'}->{ $options{weekday} }{title} = $options{title};
$self->{'week_days_holidays'}->{ $options{weekday} }{description} = $options{description};
@ -378,8 +402,12 @@ sub ModDaymonthholiday {
my %options = @_;
my $dbh = C4::Context->dbh();
my $updateHoliday = $dbh->prepare("UPDATE repeatable_holidays SET title = ?, description = ? WHERE month = ? AND day = ? AND branchcode = ?");
$updateHoliday->execute( $options{title},$options{description},$options{month},$options{day},$self->{branchcode});
my $updateHoliday = $dbh->prepare(
"UPDATE repeatable_holidays SET title = ?, description = ? WHERE month = ? AND day = ? AND branchcode = ?");
$updateHoliday->execute(
$options{title}, $options{description}, $options{month}, $options{day},
$self->{branchcode}
);
$self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{title} = $options{title};
$self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{description} = $options{description};
return $self;
@ -417,7 +445,10 @@ sub ModSingleholiday {
my $updateHoliday = $dbh->prepare( "
UPDATE special_holidays SET title = ?, description = ?
WHERE day = ? AND month = ? AND year = ? AND branchcode = ? AND isexception = ?" );
$updateHoliday->execute($options{title},$options{description},$options{day},$options{month},$options{year},$self->{branchcode},$isexception);
$updateHoliday->execute(
$options{title}, $options{description}, $options{day}, $options{month}, $options{year},
$self->{branchcode}, $isexception
);
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
@ -460,9 +491,13 @@ sub ModExceptionholiday {
my $updateHoliday = $dbh->prepare( "
UPDATE special_holidays SET title = ?, description = ?
WHERE day = ? AND month = ? AND year = ? AND branchcode = ? AND isexception = ?" );
$updateHoliday->execute($options{title},$options{description},$options{day},$options{month},$options{year},$self->{branchcode},$isexception);
$updateHoliday->execute(
$options{title}, $options{description}, $options{day}, $options{month}, $options{year},
$self->{branchcode}, $isexception
);
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} =
$options{description};
# changed the 'single_holidays' table, lets force/reset its cache
my $cache = Koha::Caches->get_instance();
@ -501,7 +536,8 @@ sub delete_holiday {
# ok just deleting it.
my $dbh = C4::Context->dbh();
my $isSingleHoliday = $dbh->prepare("SELECT id FROM special_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?) AND (year = ?)");
my $isSingleHoliday = $dbh->prepare(
"SELECT id FROM special_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?) AND (year = ?)");
$isSingleHoliday->execute( $self->{branchcode}, $options{day}, $options{month}, $options{year} );
if ( $isSingleHoliday->rows ) {
my $id = $isSingleHoliday->fetchrow;
@ -519,7 +555,9 @@ sub delete_holiday {
my $id = $isWeekdayHoliday->fetchrow;
$isWeekdayHoliday->finish; # Close the last query
my $updateExceptions = $dbh->prepare("UPDATE special_holidays SET isexception = 0 WHERE (WEEKDAY(CONCAT(special_holidays.year,'-',special_holidays.month,'-',special_holidays.day)) = ?) AND (branchcode = ?)");
my $updateExceptions = $dbh->prepare(
"UPDATE special_holidays SET isexception = 0 WHERE (WEEKDAY(CONCAT(special_holidays.year,'-',special_holidays.month,'-',special_holidays.day)) = ?) AND (branchcode = ?)"
);
$updateExceptions->execute( $options{weekday}, $self->{branchcode} );
$updateExceptions->finish; # Close the last query
@ -529,12 +567,15 @@ sub delete_holiday {
} else {
$isWeekdayHoliday->finish; # Close the last query
my $isDayMonthHoliday = $dbh->prepare("SELECT id FROM repeatable_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?)");
my $isDayMonthHoliday = $dbh->prepare(
"SELECT id FROM repeatable_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?)");
$isDayMonthHoliday->execute( $self->{branchcode}, $options{day}, $options{month} );
if ( $isDayMonthHoliday->rows ) {
my $id = $isDayMonthHoliday->fetchrow;
$isDayMonthHoliday->finish;
my $updateExceptions = $dbh->prepare("UPDATE special_holidays SET isexception = 0 WHERE (special_holidays.branchcode = ?) AND (special_holidays.day = ?) and (special_holidays.month = ?)");
my $updateExceptions = $dbh->prepare(
"UPDATE special_holidays SET isexception = 0 WHERE (special_holidays.branchcode = ?) AND (special_holidays.day = ?) and (special_holidays.month = ?)"
);
$updateExceptions->execute( $self->{branchcode}, $options{day}, $options{month} );
$updateExceptions->finish; # Close the last query
@ -552,6 +593,7 @@ sub delete_holiday {
return $self;
}
=head2 delete_holiday_range
delete_holiday_range(day => $day,
@ -573,7 +615,8 @@ sub delete_holiday_range {
my %options = @_;
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare("DELETE FROM special_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?) AND (year = ?)");
my $sth = $dbh->prepare(
"DELETE FROM special_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?) AND (year = ?)");
$sth->execute( $self->{branchcode}, $options{day}, $options{month}, $options{year} );
# changed the 'single_holidays' table, lets force/reset its cache
@ -632,7 +675,9 @@ sub delete_exception_holiday_range {
my %options = @_;
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare("DELETE FROM special_holidays WHERE (branchcode = ?) AND (isexception = 1) AND (day = ?) AND (month = ?) AND (year = ?)");
my $sth = $dbh->prepare(
"DELETE FROM special_holidays WHERE (branchcode = ?) AND (isexception = 1) AND (day = ?) AND (month = ?) AND (year = ?)"
);
$sth->execute( $self->{branchcode}, $options{day}, $options{month}, $options{year} );
# changed the 'single_holidays' table, lets force/reset its cache
@ -655,6 +700,7 @@ C<$year> Is the year to check whether if is a holiday or not.
sub isHoliday {
my ( $self, $day, $month, $year ) = @_;
# FIXME - date strings are stored in non-padded metric format. should change to iso.
$month = $month + 0;
$year = $year + 0;
@ -664,12 +710,14 @@ sub isHoliday {
my $dayMonths = $self->get_day_month_holidays();
my $exceptions = $self->get_exception_holidays();
my $singles = $self->get_single_holidays();
if ( defined( $exceptions->{"$year/$month/$day"} ) ) {
return 0;
} else {
if ((exists($weekDays->{$weekday})) ||
(exists($dayMonths->{"$month/$day"})) ||
(exists($singles->{"$year/$month/$day"}))) {
if ( ( exists( $weekDays->{$weekday} ) )
|| ( exists( $dayMonths->{"$month/$day"} ) )
|| ( exists( $singles->{"$year/$month/$day"} ) ) )
{
return 1;
} else {
return 0;
@ -698,7 +746,7 @@ sub copy_to_branch {
my $target_wdh = $target_calendar->get_week_days_holidays;
foreach my $key ( keys %$wdh ) {
unless ( grep { $_ eq $key } keys %$target_wdh ) {
$target_calendar->insert_week_day_holiday( weekday => $key, %{ $wdh->{$key} } )
$target_calendar->insert_week_day_holiday( weekday => $key, %{ $wdh->{$key} } );
}
}

85
C4/Charset.pm
View File

@ -27,6 +27,7 @@ use Encode;
use Koha::Logger;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -173,19 +174,18 @@ Sample code :
=cut
sub NormalizeString {
my ( $string, $nfd, $transform ) = @_;
return $string unless defined($string); # force scalar context return.
$string = Encode::decode( 'UTF-8', $string ) unless ( Encode::is_utf8($string) );
if ($nfd) {
$string = NFD($string);
}
else {
} else {
$string = NFC($string);
}
if ($transform) {
$string =~ s/\<|\>|\^|\;|\.|\?|,|\-|\(|\)|\[|\]|\{|\}|\$|\%|\!|\*|\:|\\|\/|\&|\"|\'/ /g;
#removing one letter words "d'" "l'" was changed into "d " "l "
$string =~ s/\b\S\b//g;
$string =~ s/\s+$//g;
@ -225,6 +225,7 @@ sub MarcToUTF8Record {
$marc_blob_is_utf8 = IsStringUTF8ish($marc_blob);
$marc_record = $marc;
} else {
# dealing with a MARC blob
# remove any ersatz whitespace from the beginning and
@ -234,19 +235,17 @@ sub MarcToUTF8Record {
$marc =~ s/^\s+//;
$marc =~ s/\s+$//;
$marc_blob_is_utf8 = IsStringUTF8ish($marc);
eval {
$marc_record = MARC::Record->new_from_usmarc($marc);
};
eval { $marc_record = MARC::Record->new_from_usmarc($marc); };
if ($@) {
# if we fail the first time, one likely problem
# is that we have a MARC21 record that says that it's
# UTF-8 (Leader/09 = 'a') but contains non-UTF-8 characters.
# We'll try parsing it again.
substr( $marc, 9, 1 ) = ' ';
eval {
$marc_record = MARC::Record->new_from_usmarc($marc);
};
eval { $marc_record = MARC::Record->new_from_usmarc($marc); };
if ($@) {
# it's hopeless; return an empty MARC::Record
return MARC::Record->new(), 'failed', ['could not parse MARC blob'];
}
@ -262,6 +261,7 @@ sub MarcToUTF8Record {
# 3. If MARC flavor is UNIMARC, then
if ( not defined $source_encoding ) {
if ($marc_blob_is_utf8) {
# note that for MARC21 we are not bothering to check
# if the Leader/09 is set to 'a' or not -- because
# of problems with various ILSs (including Koha in the
@ -278,6 +278,7 @@ sub MarcToUTF8Record {
}
}
} else {
# caller knows the character encoding
my $original_marc_record = $marc_record->clone();
my @errors;
@ -293,6 +294,7 @@ sub MarcToUTF8Record {
} elsif ( $source_encoding =~ /5426/ ) {
@errors = _marc_iso5426_to_utf8( $marc_record, $marc_flavour );
} else {
# assume any other character encoding is for Text::Iconv
@errors = _marc_to_utf8_via_text_iconv( $marc_record, $marc_flavour, $source_encoding );
}
@ -337,8 +339,7 @@ sub SetMarcUnicodeFlag {
$string = $marc_record->subfield( 100, "a" );
if ( defined $string && length($string) == $subflength ) {
$string = substr $string, 0, $subflength if ( length($string) > $subflength );
}
else {
} else {
$string = POSIX::strftime( "%Y%m%d", localtime );
$string =~ s/\-//g;
$string = sprintf( "%-*s", $subflength, $string );
@ -347,10 +348,8 @@ sub SetMarcUnicodeFlag {
substr( $string, $encodingposition, 3, "y50" );
if ( $marc_record->subfield( 100, "a" ) ) {
$marc_record->field('100')->update( a => $string );
}
else {
$marc_record->insert_grouped_field(
MARC::Field->new( 100, '', '', "a" => $string ) );
} else {
$marc_record->insert_grouped_field( MARC::Field->new( 100, '', '', "a" => $string ) );
}
Koha::Logger->get->debug( "encodage: ", substr( $marc_record->subfield( 100, 'a' ), $encodingposition, 3 ) );
} else {
@ -392,8 +391,6 @@ sub StripNonXmlChars {
return $str;
}
=head2 nsb_clean
=over 4
@ -405,6 +402,7 @@ nsb_clean($string);
Removes Non Sorting Block characters
=cut
sub nsb_clean {
my $NSB = '\x88'; # NSB : begin Non Sorting Block
my $NSE = '\x89'; # NSE : Non Sorting Block end
@ -422,7 +420,6 @@ sub nsb_clean {
return ($string);
}
=head2 SanitizeRecord
SanitizeRecord($marcrecord);
@ -438,16 +435,14 @@ sub SanitizeRecord {
my $string;
my $record_modified = 0;
my $frameworkcode = C4::Biblio::GetFrameworkCode($biblionumber);
my ( $url_field, $url_subfield ) =
C4::Biblio::GetMarcFromKohaField( 'biblioitems.url' );
my ( $url_field, $url_subfield ) = C4::Biblio::GetMarcFromKohaField('biblioitems.url');
foreach my $field ( $record->fields() ) {
if ( $field->is_control_field() ) {
my $value = $field->data();
my $sanitized_value = _clean_ampersand($value);
$record_modified = 1 if $sanitized_value ne $value;
$field->update($sanitized_value);
}
else {
} else {
my @subfields = $field->subfields();
my @new_subfields;
foreach my $subfield (@subfields) {
@ -468,8 +463,7 @@ sub SanitizeRecord {
};
if ($@) {
warn "error : $@";
}
else {
} else {
$field->replace_with($new_field);
}
@ -593,6 +587,7 @@ sub _marc_marc8_to_utf8 {
local $SIG{__WARN__} = sub {
my $msg = $_[0];
if ( $msg =~ /MARC.Charset/ ) {
# FIXME - purpose of this regexp is to strip out the
# line reference to MARC/Charset.pm, but as it
# exists probably won't work quite on Windows --
@ -601,6 +596,7 @@ sub _marc_marc8_to_utf8 {
$msg =~ s/at [\/].*?.MARC.Charset\.pm line \d+\.\n$//;
push @errors, $msg;
} else {
# if warning doesn't come from MARC::Charset, just
# pass it on
warn $msg;
@ -615,6 +611,7 @@ sub _marc_marc8_to_utf8 {
foreach my $subfield ( $field->subfields() ) {
my $utf8sf = MARC::Charset::marc8_to_utf8( $subfield->[1] );
unless ( IsStringUTF8ish($utf8sf) ) {
# Because of a bug in MARC::Charset 0.98, if the string
# has (a) one or more diacritics that (b) are only in character positions
# 128 to 255 inclusive, the resulting converted string is not in
@ -627,9 +624,11 @@ sub _marc_marc8_to_utf8 {
push @converted_subfields, $subfield->[0], $utf8sf;
}
$field->replace_with(MARC::Field->new(
$field->replace_with(
MARC::Field->new(
$field->tag(), $field->indicator(1), $field->indicator(2),
@converted_subfields)
@converted_subfields
)
);
}
}
@ -671,9 +670,11 @@ sub _marc_iso5426_to_utf8 {
push @converted_subfields, $subfield->[0], $utf8sf;
}
$field->replace_with(MARC::Field->new(
$field->replace_with(
MARC::Field->new(
$field->tag(), $field->indicator(1), $field->indicator(2),
@converted_subfields)
@converted_subfields
)
);
}
}
@ -739,9 +740,11 @@ sub _marc_to_utf8_via_text_iconv {
}
}
$field->replace_with(MARC::Field->new(
$field->replace_with(
MARC::Field->new(
$field->tag(), $field->indicator(1), $field->indicator(2),
@converted_subfields)
@converted_subfields
)
);
}
}
@ -781,9 +784,11 @@ sub _marc_to_utf8_replacement_char {
push @converted_subfields, $subfield->[0], $value;
}
$field->replace_with(MARC::Field->new(
$field->replace_with(
MARC::Field->new(
$field->tag(), $field->indicator(1), $field->indicator(2),
@converted_subfields)
@converted_subfields
)
);
}
}
@ -799,19 +804,22 @@ Converts a string from ISO-5426 to UTF-8.
=cut
my %chars;
####
## 0xb
$chars{0xb0} = 0x0101; #3/0ayn[ain]
$chars{0xb1} = 0x0623; #3/1alif/hamzah[alefwithhamzaabove]
#$chars{0xb2}=0x00e0;#'à';
$chars{0xb2} = 0x00e0; #3/2leftlowsinglequotationmark
#$chars{0xb3}=0x00e7;#'ç';
$chars{0xb3} = 0x00e7; #3/2leftlowsinglequotationmark
# $chars{0xb4}='è';
$chars{0xb4} = 0x00e8;
# $chars{0xb5}='é';
$chars{0xb5} = 0x00e9;
$chars{0xb6} = 0x2021; # double dagger
@ -852,6 +860,7 @@ $chars{0xfc}=0x00fe; # latin small letter thorn
## Others
$chars{0x97} = 0x003c; #3/2leftlowsinglequotationmark
$chars{0x98} = 0x003e; #3/2leftlowsinglequotationmark
#$chars{0x81d1}=0x00b0; # FIXME useless
####
@ -1209,6 +1218,7 @@ $chars{0xda20}=0x02cc; #
# 5/13 left half of ligature sign and of double tilde
# 5/14 right half of ligature sign
# 5/15 right half of double tilde
# map {printf "%x :%x\n",$_,$chars{$_};}keys %chars;
sub char_decode5426 {
@ -1221,18 +1231,22 @@ sub char_decode5426 {
for ( my $i = 0 ; $i < scalar(@data) ; $i++ ) {
my $char = $data[$i];
if ( $char >= 0x00 && $char <= 0x7F ) {
#IsAscii
push @characters, $char unless ( $char < 0x02 || $char == 0x0F );
} elsif ( ( $char >= 0xC0 && $char <= 0xDF ) ) {
#Combined Char
my $convchar;
if ( $chars{ $char * 256 + $data[ $i + 1 ] } ) {
$convchar = $chars{ $char * 256 + $data[ $i + 1 ] };
$i++;
# printf "char %x $char, char to convert %x , converted %x\n",$char,$char * 256 + $data[$i - 1],$convchar;
} elsif ( $chars{$char} ) {
$convchar = $chars{$char};
# printf "0xC char %x, converted %x\n",$char,$chars{$char};
} else {
$convchar = $char;
@ -1242,8 +1256,10 @@ sub char_decode5426 {
my $convchar;
if ( $chars{$char} ) {
$convchar = $chars{$char};
# printf "char %x, converted %x\n",$char,$chars{$char};
} else {
# printf "char %x $char\n",$char;
$convchar = $char;
}
@ -1251,12 +1267,14 @@ sub char_decode5426 {
}
}
$result = pack "U*", @characters;
# $result=~s/\x01//;
# $result=~s/\x00//;
$result =~ s/\x0f//;
$result =~ s/\x1b.//;
$result =~ s/\x0e//;
$result =~ s/\x1b\x5b//;
# map{printf "%x",$_} @characters;
# printf "\n";
return $result;
@ -1264,7 +1282,6 @@ sub char_decode5426 {
1;
=head1 AUTHOR
Koha Development Team <http://koha-community.org/>

707
C4/Circulation.pm
View File

File diff suppressed because it is too large Load Diff

2
C4/ClassSortRoutine.pm
View File

@ -22,6 +22,7 @@ use Modern::Perl;
use Class::Factory::Util;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -93,6 +94,7 @@ sub GetClassSortKey {
$loaded_routines{$sort_routine} = \&_get_class_sort_key;
}
my $key = $loaded_routines{$sort_routine}->( $cn_class, $cn_item );
# FIXME -- hardcoded length for cn_sort
# should replace with some way of getting column widths from
# the DB schema -- since doing this should ideally be

8
C4/ClassSortRoutine/Dewey.pm
View File

@ -20,8 +20,6 @@ package C4::ClassSortRoutine::Dewey;
use strict;
use warnings;
=head1 NAME
C4::ClassSortRoutine::Dewey - generic call number sorting key routine
@ -66,6 +64,7 @@ sub get_class_sort_key {
my @tokens = split /\.|\s+/, $init;
my $digit_group_count = 0;
my $first_digit_group_idx;
for ( my $i = 0 ; $i <= $#tokens ; $i++ ) {
if ( $tokens[$i] =~ /^\d+$/ ) {
$digit_group_count++;
@ -77,14 +76,15 @@ sub get_class_sort_key {
$tokens[$i] = sprintf( "%-15.15s", $tokens[$i] );
$tokens[$i] =~ tr/ /0/;
} else {
$tokens[$first_digit_group_idx] .= '_000000000000000'
$tokens[$first_digit_group_idx] .= '_000000000000000';
}
}
}
}
# Pad the first digit_group if there was only one
if ( 1 == $digit_group_count ) {
$tokens[$first_digit_group_idx] .= '_000000000000000'
$tokens[$first_digit_group_idx] .= '_000000000000000';
}
my $key = join( "_", @tokens );
$key =~ s/[^\p{IsAlnum}_]//g;

2
C4/ClassSortRoutine/Generic.pm
View File

@ -20,8 +20,6 @@ package C4::ClassSortRoutine::Generic;
use strict;
use warnings;
=head1 NAME
C4::ClassSortRoutine::Generic - generic call number sorting key routine

2
C4/ClassSortRoutine/LCC.pm
View File

@ -22,8 +22,6 @@ use strict;
use warnings;
use Library::CallNumber::LC;
=head1 NAME
C4::ClassSortRoutine::LCC - generic call number sorting key routine

3
C4/ClassSource.pm
View File

@ -24,6 +24,7 @@ use C4::ClassSortRoutine qw( GetClassSortKey );
use Koha::Cache::Memory::Lite;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -79,7 +80,7 @@ foreach my $cn_source (sort keys %$sources) {
sub GetClassSources {
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
my $class_sources = $memory_cache->get_from_cache( "GetClassSource:All" );;
my $class_sources = $memory_cache->get_from_cache("GetClassSource:All");
unless ($class_sources) {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM `class_sources`");

1
C4/ClassSplitRoutine.pm
View File

@ -22,6 +22,7 @@ use Modern::Perl;
use Class::Factory::Util;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);

6
C4/ClassSplitRoutine/Dewey.pm
View File

@ -40,8 +40,7 @@ my $cn_split = C4::ClassSplitRoutine::Dewey::split_callnumber($cn_item);
sub split_callnumber {
my ($cn_item) = @_;
my $possible_decimal =
qr/\d{3,}(?:\.\d+)?/; # at least three digits for a DDCN
my $possible_decimal = qr/\d{3,}(?:\.\d+)?/; # at least three digits for a DDCN
$cn_item =~ s/\///g
; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
@ -62,8 +61,7 @@ sub split_callnumber {
}
push @lines, split /\s+/,
pop @lines
; # split the last piece into an arbitrary number of pieces at spaces
pop @lines; # split the last piece into an arbitrary number of pieces at spaces
return @lines;
}

3
C4/ClassSplitRoutine/Generic.pm
View File

@ -46,8 +46,7 @@ sub split_callnumber {
my @lines;
# Split call numbers based on spaces
push @lines, split /\s+/, $cn_item
; # split the call number into an arbitrary number of pieces at spaces
push @lines, split /\s+/, $cn_item; # split the call number into an arbitrary number of pieces at spaces
if ( $lines[-1] !~ /^.*\d-\d.*$/ && $lines[-1] =~ /^(.*\d+)(\D.*)$/ ) {
pop @lines; # pull off the matching last element
push @lines, $1, $2; # replace it with the two pieces

4
C4/ClassSplitRoutine/LCC.pm
View File

@ -42,6 +42,7 @@ my $cn_split = C4::ClassSplitRoutine::LCC::split_callnumber($cn_item);
sub split_callnumber {
my ($cn_item) = @_;
# lccn examples: 'HE8700.7 .P6T44 1983', 'BS2545.E8 H39 1996';
my @lines = Library::CallNumber::LC->new($cn_item)->components();
unless ( scalar @lines && defined $lines[0] ) {
@ -49,7 +50,8 @@ sub split_callnumber {
@lines = $cn_item; # if no match, just use the whole string.
}
my $LastPiece = pop @lines;
push @lines, split /\s+/, $LastPiece if $LastPiece; # split the last piece into an arbitrary number of pieces at spaces
push @lines, split /\s+/, $LastPiece
if $LastPiece; # split the last piece into an arbitrary number of pieces at spaces
return @lines;
}

54
C4/Context.pm
View File

@ -20,6 +20,7 @@ package C4::Context;
use Modern::Perl;
use vars qw($AUTOLOAD $context);
BEGIN {
if ( $ENV{'HTTP_USER_AGENT'} ) { # Only hit when plack is not enabled
@ -33,7 +34,7 @@ BEGIN {
$CGI::LIST_CONTEXT_WARN = 0;
}
}
};
}
use Carp qw( carp );
use DateTime::TimeZone;
@ -103,6 +104,7 @@ environment variable to the pathname of a configuration file to use.
$context = undef; # Initially, no context is set
sub import {
# Create the default context ($C4::Context::Context)
# the first time the module is called
# (a config file can be optionaly passed)
@ -146,8 +148,9 @@ sub new {
my $conf_fname = shift; # Config file to load
# check that the specified config file exists and is not empty
undef $conf_fname unless
(defined $conf_fname && -s $conf_fname);
undef $conf_fname
unless ( defined $conf_fname && -s $conf_fname );
# Figure out a good config file to load if none was specified.
unless ( defined $conf_fname ) {
$conf_fname = Koha::Config->guess_koha_conf;
@ -183,8 +186,7 @@ or
=cut
#'
sub set_context
{
sub set_context {
my $self = shift;
my $new_context; # The context to set
@ -197,11 +199,12 @@ sub set_context
# 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 "")
{
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;
}
@ -230,6 +233,7 @@ sub _common_config {
sub config {
return _common_config( $_[1], 'config' );
}
sub zebraconfig {
return _common_config( $_[1], 'server' );
}
@ -251,6 +255,7 @@ with this method.
=cut
my $use_syspref_cache = 1;
sub preference {
my $self = shift;
my $var = shift; # The system preference to return
@ -295,7 +300,10 @@ sub yaml_preference {
}
# TODO Remove next line when enforced elsewhere
if( $yaml && lc($preference) eq 'itemsdeniedrenewal' and ref($yaml) ne 'HASH' ) { warn "Hashref expected for $preference"; return; }
if ( $yaml && lc($preference) eq 'itemsdeniedrenewal' and ref($yaml) ne 'HASH' ) {
warn "Hashref expected for $preference";
return;
}
return $yaml;
}
@ -327,6 +335,7 @@ default behavior.
sub enable_syspref_cache {
my ($self) = @_;
$use_syspref_cache = 1;
# We need to clear the cache to have it up-to-date
$self->clear_syspref_cache();
}
@ -394,7 +403,8 @@ sub set_preference {
if ($syspref) {
$syspref->set(
{ ( defined $value ? ( value => $value ) : () ),
{
( defined $value ? ( value => $value ) : () ),
( $explanation ? ( explanation => $explanation ) : () ),
( $type ? ( type => $type ) : () ),
( $options ? ( options => $options ) : () ),
@ -402,7 +412,8 @@ sub set_preference {
)->store;
} else {
$syspref = Koha::Config::SysPref->new(
{ variable => $variable_case,
{
variable => $variable_case,
value => $value,
explanation => $explanation || undef,
type => $type,
@ -513,11 +524,15 @@ C<$async> whether this is a asynchronous connection
sub Zconn {
my ( $self, $server, $async ) = @_;
my $cache_key = join( '::', ( map { $_ // '' } ( $server, $async ) ) );
if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
if ( ( !defined( $ENV{GATEWAY_INTERFACE} ) )
&& defined( $context->{"Zconn"}->{$cache_key} )
&& ( 0 == $context->{"Zconn"}->{$cache_key}->errcode() ) )
{
# if we are running the script from the commandline, lets try to use the caching
return $context->{"Zconn"}->{$cache_key};
}
$context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
$context->{"Zconn"}->{$cache_key}->destroy()
if defined( $context->{"Zconn"}->{$cache_key} ); #destroy old connection before making a new one
$context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
return $context->{"Zconn"}->{$cache_key};
}
@ -585,8 +600,7 @@ sub _new_Zconn {
# 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
{
sub _new_dbh {
Koha::Database->schema( { new => 1 } )->storage->dbh;
}
@ -601,8 +615,7 @@ creates one, and connects to the database.
=cut
sub dbh
{
sub dbh {
my $self = shift;
my $params = shift;
@ -627,8 +640,7 @@ connect to so that the caller doesn't have to know.
=cut
#'
sub new_dbh
{
sub new_dbh {
my $self = shift;
return &dbh( { new => 1 } );
@ -701,12 +713,10 @@ Destroys user environment variables.
=cut
sub unset_userenv
{
sub unset_userenv {
$context->{userenv} = undef;
}
=head2 get_versions
C4::Context->get_versions
@ -758,7 +768,6 @@ sub tz {
return $context->{tz};
}
=head2 IsSuperLibrarian
C4::Context->IsSuperLibrarian();
@ -769,6 +778,7 @@ sub IsSuperLibrarian {
my $userenv = C4::Context->userenv;
unless ( $userenv and exists $userenv->{flags} ) {
# If we reach this without a user environment,
# assume that we're running from a command-line script,
# and act as a superlibrarian.

7
C4/Contract.pm
View File

@ -51,7 +51,6 @@ a contract.
=cut
=head2 GetContracts
$contractlist = GetContracts({
@ -102,9 +101,11 @@ sub GetContract {
return unless $contractnumber;
my $contracts = GetContracts({
my $contracts = GetContracts(
{
contractnumber => $contractnumber,
});
}
);
return $contracts->[0];
}

54
C4/CourseReserves.pm
View File

@ -29,6 +29,7 @@ use Koha::Checkouts;
use vars qw(@FIELDS);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -177,7 +178,8 @@ sub GetCourses {
$query .= join( ' AND ', @query_keys );
}
$query .= " GROUP BY c.course_id, c.department, c.course_number, c.section, c.course_name, c.term, c.staff_note, c.public_note, c.students_count, c.enabled, c.timestamp ";
$query .=
" GROUP BY c.course_id, c.department, c.course_number, c.section, c.course_name, c.term, c.staff_note, c.public_note, c.students_count, c.enabled, c.timestamp ";
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare($query);
@ -249,11 +251,13 @@ sub EnableOrDisableCourseItems {
if ( $enabled eq 'yes' ) {
foreach my $course_reserve (@$course_reserves) {
if (CountCourseReservesForItem(
if (
CountCourseReservesForItem(
ci_id => $course_reserve->{'ci_id'},
enabled => 'yes'
)
) {
)
{
EnableOrDisableCourseItem(
ci_id => $course_reserve->{'ci_id'},
);
@ -267,7 +271,8 @@ sub EnableOrDisableCourseItems {
ci_id => $course_reserve->{'ci_id'},
enabled => 'yes'
)
) {
)
{
EnableOrDisableCourseItem(
ci_id => $course_reserve->{'ci_id'},
);
@ -291,7 +296,10 @@ sub EnableOrDisableCourseItem {
my $course_item = GetCourseItem( ci_id => $ci_id );
my $info = $course_item->{itemnumber} ? GetItemCourseReservesInfo( itemnumber => $course_item->{itemnumber} ) : GetItemCourseReservesInfo( biblionumber => $course_item->{biblionumber} );
my $info =
$course_item->{itemnumber}
? GetItemCourseReservesInfo( itemnumber => $course_item->{itemnumber} )
: GetItemCourseReservesInfo( biblionumber => $course_item->{biblionumber} );
my $enabled = any { $_->{course}->{enabled} eq 'yes' } @$info;
$enabled = $enabled ? 'yes' : 'no';
@ -468,7 +476,8 @@ sub ModCourseItem {
return unless ( $itemnumber xor $biblionumber );
my $course_item = $itemnumber ? GetCourseItem( itemnumber => $itemnumber ) : GetCourseItem( biblionumber => $biblionumber );
my $course_item =
$itemnumber ? GetCourseItem( itemnumber => $itemnumber ) : GetCourseItem( biblionumber => $biblionumber );
if ( $itemnumber and !$biblionumber ) {
$biblionumber = Koha::Items->find($itemnumber)->biblionumber;
@ -543,6 +552,7 @@ sub _UpdateCourseItem {
my %enabled = map { $_ . "_enabled" => $params{ $_ . "_enabled" } } @FIELDS;
if ( $course_item->itemnumber ) {
# biblio-level course items don't store any of these fields
my $item = Koha::Items->find( $course_item->itemnumber );
@ -560,11 +570,13 @@ sub _UpdateCourseItem {
$enabled{$field_storage} = $item->$field;
$item_fields->{$field} = $params{$field};
}
# Find newly disabled field and copy the storage value to the item, unset storage value
elsif ( !$params{$field_enabled} && $course_item->$field_enabled ) {
$item_fields->{$field} = $course_item->$field_storage;
$enabled{$field_storage} = undef;
}
# The field was already enabled, copy the incoming value to the item.
# The "original" ( when not on course reserve ) value is already in the storage field
elsif ( $course_item->$field_enabled ) {
@ -605,9 +617,7 @@ sub _RevertFields {
$item_fields->{homebranch} = $course_item->homebranch_storage if $course_item->homebranch_enabled;
$item_fields->{holdingbranch} = $course_item->holdingbranch_storage if $course_item->holdingbranch_enabled;
Koha::Items->find( $course_item->itemnumber )
->set( $item_fields )
->store
Koha::Items->find( $course_item->itemnumber )->set($item_fields)->store
if keys %$item_fields;
$course_item->itype_storage(undef);
@ -645,9 +655,7 @@ sub _SwapAllFields {
$item_fields->{homebranch} = $course_item->homebranch if $course_item->homebranch_enabled;
$item_fields->{holdingbranch} = $course_item->holdingbranch if $course_item->holdingbranch_enabled;
Koha::Items->find( $course_item->itemnumber )
->set( $item_fields )
->store
Koha::Items->find( $course_item->itemnumber )->set($item_fields)->store
if keys %$item_fields;
} else { # Copy course item storage to item
@ -658,9 +666,7 @@ sub _SwapAllFields {
$item_fields->{homebranch} = $course_item->homebranch_storage if $course_item->homebranch_enabled;
$item_fields->{holdingbranch} = $course_item->holdingbranch_storage if $course_item->holdingbranch_enabled;
Koha::Items->find( $course_item->itemnumber )
->set( $item_fields )
->store
Koha::Items->find( $course_item->itemnumber )->set($item_fields)->store
if keys %$item_fields;
$course_item->itype_storage(undef);
@ -867,7 +873,10 @@ sub GetCourseReserves {
if ($include_items) {
foreach my $cr (@$course_reserves) {
my $item = Koha::Items->find( $cr->{itemnumber}, { prefetch => [ 'biblio', 'biblioitem' ] } );
my $biblio = $cr->{itemnumber} ? $item->biblio : Koha::Biblios->find( $cr->{biblionumber}, { prefetch => ['biblioitem'] });
my $biblio =
$cr->{itemnumber}
? $item->biblio
: Koha::Biblios->find( $cr->{biblionumber}, { prefetch => ['biblioitem'] } );
my $biblioitem = $biblio->biblioitem;
$cr->{'course_item'} = GetCourseItem( ci_id => $cr->{'ci_id'} );
$cr->{'item'} = $item;
@ -885,7 +894,10 @@ sub GetCourseReserves {
if ($include_courses) {
foreach my $cr (@$course_reserves) {
$cr->{'courses'} = $cr->{itemnumber} ? GetCourses( itemnumber => $cr->{'itemnumber'} ) : GetCourses( biblionumber => $cr->{biblionumber} );
$cr->{'courses'} =
$cr->{itemnumber}
? GetCourses( itemnumber => $cr->{'itemnumber'} )
: GetCourses( biblionumber => $cr->{biblionumber} );
}
}
@ -941,7 +953,8 @@ sub GetItemCourseReservesInfo {
return unless ( $itemnumber xor $biblionumber );
my $course_item = $itemnumber ? GetCourseItem( itemnumber => $itemnumber ) : GetCourseItem( biblionumber => $biblionumber );
my $course_item =
$itemnumber ? GetCourseItem( itemnumber => $itemnumber ) : GetCourseItem( biblionumber => $biblionumber );
return unless ( keys %$course_item );
@ -980,7 +993,10 @@ sub CountCourseReservesForItem {
return unless ( $ci_id xor $itemnumber xor $biblionumber );
my $course_item = GetCourseItem( ci_id => $ci_id ) || GetCourseItem( itemnumber => $itemnumber ) || GetCourseItem( biblionumber => $biblionumber );
my $course_item =
GetCourseItem( ci_id => $ci_id )
|| GetCourseItem( itemnumber => $itemnumber )
|| GetCourseItem( biblionumber => $biblionumber );
my @params = ( $course_item->{'ci_id'} );
push( @params, $enabled ) if ($enabled);

34
C4/Creators/Batch.pm
View File

@ -27,8 +27,7 @@ sub _check_params {
$exit_code = 1;
}
}
}
else {
} else {
if ( !( grep m/$_/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of %s', $_ );
$exit_code = 1;
@ -63,8 +62,10 @@ sub add_item {
my $batch_id = $sth->fetchrow_array;
$self->{'batch_id'} = ++$batch_id;
}
my $query = "INSERT INTO creator_batches (batch_id, description, $number_type, branch_code, creator) VALUES (?,?,?,?,?);";
my $query =
"INSERT INTO creator_batches (batch_id, description, $number_type, branch_code, creator) VALUES (?,?,?,?,?);";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute( $self->{'batch_id'}, $self->{'description'}, $number, $self->{'branch_code'}, $1 );
if ( $sth->err ) {
@ -90,6 +91,7 @@ sub remove_item {
my $label_id = shift;
my $query = "DELETE FROM creator_batches WHERE label_id=? AND batch_id=?;";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute( $label_id, $self->{'batch_id'} );
if ( $sth->err ) {
@ -140,6 +142,7 @@ sub retrieve {
my $record_flag = 0;
my $query = "SELECT * FROM creator_batches WHERE batch_id = ? ORDER BY label_id";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute( $opts{'batch_id'} );
my $self = {
@ -172,8 +175,7 @@ sub delete {
$self = shift; # check to see if this is a method call
$call_type = 'C4::Labels::Batch->delete'; # seems hackish
@query_params = ( $self->{'batch_id'}, $self->{'branch_code'} );
}
else {
} else {
shift @_;
%opts = @_;
$call_type = 'C4::Labels::Batch::delete';
@ -185,6 +187,7 @@ sub delete {
}
my $query = "DELETE FROM creator_batches WHERE batch_id = ? AND branch_code =?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute(@query_params);
if ( $sth->err ) {
@ -199,19 +202,24 @@ sub remove_duplicates {
my %seen = ();
my $query = "DELETE FROM creator_batches WHERE label_id = ?;"; # ORDER BY timestamp ASC LIMIT ?;";
my $sth = C4::Context->dbh->prepare($query);
my @duplicate_items = grep{
$_->{'item_number'}
? $seen{$_->{'item_number'}}++
: $seen{$_->{'borrower_number'}}++
} @{$self->{'items'}};
my @duplicate_items =
grep { $_->{'item_number'} ? $seen{ $_->{'item_number'} }++ : $seen{ $_->{'borrower_number'} }++ }
@{ $self->{'items'} };
foreach my $item (@duplicate_items) {
$sth->execute( $item->{'label_id'} );
if ( $sth->err ) {
warn sprintf('Database returned the following error on attempted DELETE for label_id %s: %s', $item->{'label_id'}, $sth->errstr);
warn sprintf(
'Database returned the following error on attempted DELETE for label_id %s: %s',
$item->{'label_id'}, $sth->errstr
);
return -1;
}
$sth->finish(); # Per DBI.pm docs: "If execute() is called on a statement handle that's still active ($sth->{Active} is true) then it should effectively call finish() to tidy up the previous execution results before starting this new execution."
@{$self->{'items'}} = grep{$_->{'label_id'} != $item->{'label_id'}} @{$self->{'items'}}; # the correct label/item must be removed from the current batch object as well; this should be done *after* each sql DELETE in case the DELETE fails
$sth->finish()
; # Per DBI.pm docs: "If execute() is called on a statement handle that's still active ($sth->{Active} is true) then it should effectively call finish() to tidy up the previous execution results before starting this new execution."
@{ $self->{'items'} } =
grep { $_->{'label_id'} != $item->{'label_id'} }
@{ $self->{'items'} }
; # the correct label/item must be removed from the current batch object as well; this should be done *after* each sql DELETE in case the DELETE fails
}
return scalar(@duplicate_items);
}

27
C4/Creators/Layout.pm
View File

@ -49,8 +49,7 @@ sub _check_params {
$exit_code = 1;
}
}
}
else {
} else {
if ( !( grep m/$_/, @valtmpl_id_params ) ) {
warn sprintf( '(Single parameter) Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
@ -60,6 +59,7 @@ sub _check_params {
}
use constant PRESET_FIELDS => [qw(title author isbn issn itemtype barcode itemcallnumber)];
sub new {
my $invocant = shift;
my $self = '';
@ -86,12 +86,11 @@ sub new {
format_string => join( ', ', @{ PRESET_FIELDS() } ),
@_,
};
}
elsif (grep {$_ eq 'Patroncards'} @_) {
} elsif ( grep { $_ eq 'Patroncards' } @_ ) {
$self = {
layout_xml => '<opt>Default Layout</opt>',
@_,
}
};
}
bless( $self, $type );
return $self;
@ -122,16 +121,17 @@ sub delete {
$self = shift; # check to see if this is a method call
$call_type = 'C4::Labels::Layout->delete';
push @params, $self->{'layout_id'}, $self->{'creator'};
}
else {
} else {
my $class = shift;
%opts = @_;
$call_type = $class . '::delete';
push @params, $opts{'layout_id'}, $opts{'creator'};
}
if ( scalar(@params) < 2 ) { # If there is no layout id or creator type then we cannot delete it
warn sprintf('%s : Cannot delete layout as the profile ID is invalid or non-existent.', $call_type) if !$params[0];
warn sprintf('%s : Cannot delete layout as the creator type is invalid or non-existent.', $call_type) if !$params[1];
warn sprintf( '%s : Cannot delete layout as the profile ID is invalid or non-existent.', $call_type )
if !$params[0];
warn sprintf( '%s : Cannot delete layout as the creator type is invalid or non-existent.', $call_type )
if !$params[1];
return -1;
}
my $query = "DELETE FROM creator_layouts WHERE layout_id = ? AND creator = ?";
@ -157,6 +157,7 @@ sub save {
$query .= " WHERE layout_id=? AND creator = ?;";
push( @params, $self->{'layout_id'}, $self->{'creator'} );
my $sth = C4::Context->dbh->prepare($query);
#local $sth->{TraceLevel} = "3"; # enable DBI trace and set level; outputs to STDERR
$sth->execute(@params);
if ( $sth->err ) {
@ -164,8 +165,7 @@ sub save {
return -1;
}
return $self->{'layout_id'};
}
else { # otherwise create a new record
} else { # otherwise create a new record
my @params;
delete $self->{layout_id}; # Could be an empty string
my $query = "INSERT INTO creator_layouts (";
@ -202,8 +202,7 @@ sub get_attr {
my ($attr) = @_;
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
return;
@ -217,7 +216,7 @@ sub set_attr {
my %attrs = @_;
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
return 0;
}

103
C4/Creators/Lib.pm
View File

@ -70,6 +70,7 @@ sub _SELECT {
my $query = "SELECT $fieldname FROM $params[1]";
$params[2] ? $query .= " WHERE $params[2];" : $query .= ';';
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute();
if ( $sth->err ) {
@ -86,25 +87,55 @@ sub _SELECT {
sub _add_backtics {
my (@args) = @_;
s/(?:^|\b)(\w+)(?:\b|$)/`$1`/g for @args;
# Too bad that we need to correct a few exceptions: aggregate functions
my @aggregates = ( 'COUNT', 'MAX', 'MIN', 'SUM' ); # add when needed..
foreach my $aggr (@aggregates) {
s/`$aggr`\(/$aggr\(/gi for @args;
}
# And correct aliases
s/(`|\))\s+`AS`\s+`/$1 AS `/gi for @args;
return wantarray ? @args : $args[0];
}
my $barcode_types = [
{type => 'CODE39', name => 'Code 39', desc => 'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern.', selected => 0},
{type => 'CODE39MOD', name => 'Code 39 + Modulo43', desc => 'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern. Encodes Mod 43 checksum.', selected => 0},
{type => 'CODE39MOD10', name => 'Code 39 + Modulo10', desc => 'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern. Encodes Mod 10 checksum.', selected => 0},
{type => 'COOP2OF5', name => 'COOP2of5', desc => 'Creates COOP2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0},
{type => 'EAN13', name => 'EAN13', desc => 'Creates EAN13 barcodes from a string of 12 or 13 digits. The check number (the 13:th digit) is calculated if not supplied.', selected => 0},
{
type => 'CODE39', name => 'Code 39',
desc =>
'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern.',
selected => 0
},
{
type => 'CODE39MOD', name => 'Code 39 + Modulo43',
desc =>
'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern. Encodes Mod 43 checksum.',
selected => 0
},
{
type => 'CODE39MOD10', name => 'Code 39 + Modulo10',
desc =>
'Translates the characters 0-9, A-Z, \'-\', \'*\', \'+\', \'$\', \'%\', \'/\', \'.\' and \' \' to a barcode pattern. Encodes Mod 10 checksum.',
selected => 0
},
{
type => 'COOP2OF5', name => 'COOP2of5',
desc => 'Creates COOP2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0
},
{
type => 'EAN13', name => 'EAN13',
desc =>
'Creates EAN13 barcodes from a string of 12 or 13 digits. The check number (the 13:th digit) is calculated if not supplied.',
selected => 0
},
# {type => 'EAN8', name => 'EAN8', desc => 'Translates a string of 7 or 8 digits to EAN8 barcodes. The check number (the 8:th digit) is calculated if not supplied.', selected => 0},
# {type => 'IATA2of5', name => 'IATA2of5', desc => 'Creates IATA2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0},
{type => 'INDUSTRIAL2OF5', name => 'Industrial2of5', desc => 'Creates Industrial2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0},
{
type => 'INDUSTRIAL2OF5', name => 'Industrial2of5',
desc => 'Creates Industrial2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0
},
# {type => 'ITF', name => 'Interleaved2of5', desc => 'Translates the characters 0-9 to a barcodes. These barcodes could also be called 'Interleaved2of5'.', selected => 0},
# {type => 'MATRIX2OF5', name => 'Matrix2of5', desc => 'Creates Matrix2of5 barcodes from a string consisting of the numeric characters 0-9', selected => 0},
# {type => 'NW7', name => 'NW7', desc => 'Creates a NW7 barcodes from a string consisting of the numeric characters 0-9', selected => 0},
@ -116,7 +147,10 @@ my $label_types = [
{ type => 'BIB', name => 'Biblio', desc => 'Only the bibliographic data is printed.', selected => 0 },
{ type => 'BARBIB', name => 'Barcode/Biblio', desc => 'Barcode proceeds bibliographic data.', selected => 0 },
{ type => 'BIBBAR', name => 'Biblio/Barcode', desc => 'Bibliographic data proceeds barcode.', selected => 0 },
{type => 'ALT', name => 'Alternating', desc => 'Barcode and bibliographic data are printed on alternating labels.', selected => 0},
{
type => 'ALT', name => 'Alternating',
desc => 'Barcode and bibliographic data are printed on alternating labels.', selected => 0
},
{ type => 'BAR', name => 'Barcode', desc => 'Only the barcode is printed.', selected => 0 },
];
@ -139,6 +173,7 @@ my $text_justification_types = [
{ type => 'L', name => 'Left', selected => 0 },
{ type => 'C', name => 'Center', selected => 0 },
{ type => 'R', name => 'Right', selected => 0 },
# {type => 'F', name => 'Full', selected => 0},
];
@ -164,7 +199,10 @@ sub _build_query {
$query .= ' WHERE 1 ';
while ( my ( $field, $values ) = each %{ $params->{filters} } ) {
if ( ref($values) ) {
$query .= " AND `$field` IN ( " . ( ('?,') x (@$values-1) ) . "? ) "; # a comma separates elements in a list...
$query .=
" AND `$field` IN ( "
. ( ('?,') x ( @$values - 1 ) )
. "? ) "; # a comma separates elements in a list...
push @where_args, @$values;
} else {
$query .= " AND `$field` = ? ";
@ -341,12 +379,15 @@ sub get_label_summary {
my $record = $sth->fetchrow_hashref;
my $label_summary;
$label_summary->{'_label_number'} = $label_number;
$record->{'author'} =~ s/[^\.|\w]$// if $record->{'author'}; # strip off ugly trailing chars... but not periods or word chars
$record->{'author'} =~ s/[^\.|\w]$//
if $record->{'author'}; # strip off ugly trailing chars... but not periods or word chars
$record->{'title'} =~ s/\W*$//; # strip off ugly trailing chars
# FIXME contructing staff interface URLs should be done *much* higher up the stack - for the most part, C4 module code
# should not know that it's part of a web app
$label_summary->{'_summary'} = { title => $record->{title}, author => $record->{author}, biblionumber => $record->{biblionumber} };
$label_summary->{'_item_type'} = C4::Context->preference("item-level_itypes") ? $record->{'itype'} : $record->{'itemtype'};
$label_summary->{'_summary'} =
{ title => $record->{title}, author => $record->{author}, biblionumber => $record->{biblionumber} };
$label_summary->{'_item_type'} =
C4::Context->preference("item-level_itypes") ? $record->{'itype'} : $record->{'itemtype'};
$label_summary->{'_barcode'} = $record->{'barcode'};
$label_summary->{'_item_number'} = $item->{'item_number'};
$label_summary->{'_item_cn'} = $record->{'itemcallnumber'};
@ -467,7 +508,6 @@ sub get_output_formats {
return dclone $output_formats;
}
=head2 C4::Creators::Lib::get_table_names($search_term)
Return an arrayref of an array containing the table names which contain the supplied search term.
@ -534,19 +574,27 @@ sub html_table {
my $select_value = undef;
my $link_field = undef;
POPULATE_HEADER:
foreach my $header (@$headers) {
my @key = keys %$header;
if ( $key[0] eq 'select' ) {
push( @table_columns, $key[0] );
$$fields[$col_index] = {hidden => 0, select_field => 0, field_name => ($key[0]), field_label => $header->{$key[0]}{'label'}};
$$fields[$col_index] = {
hidden => 0, select_field => 0, field_name => ( $key[0] ),
field_label => $header->{ $key[0] }{'label'}
};
# do special formatting stuff....
$select_value = $header->{ $key[0] }{'value'};
}
else {
} else {
# do special formatting stuff....
$link_field->{ $key[0] } = ( $header->{ $key[0] }{'link_field'} == 1 ? 1 : 0 );
push( @table_columns, $key[0] );
$$fields[$col_index] = {hidden => 0, select_field => 0, field_name => ($key[0]), field_label => $header->{$key[0]}{'label'}};
$$fields[$col_index] = {
hidden => 0, select_field => 0, field_name => ( $key[0] ),
field_label => $header->{ $key[0] }{'label'}
};
}
$field_count++;
$col_index++;
@ -558,23 +606,30 @@ sub html_table {
$row_index++;
$fields = [];
POPULATE_TABLE:
foreach my $db_row (@$data) {
POPULATE_ROW:
foreach my $table_column (@table_columns) {
if ( grep { $table_column eq $_ } keys %$db_row ) {
$$fields[$col_index] = {hidden => 0, link_field => $link_field->{$table_column}, select_field => 0, field_name => ($table_column . "_tbl"), field_value => $db_row->{$table_column}};
$$fields[$col_index] = {
hidden => 0, link_field => $link_field->{$table_column}, select_field => 0,
field_name => ( $table_column . "_tbl" ), field_value => $db_row->{$table_column}
};
$col_index++;
next POPULATE_ROW;
}
elsif ($table_column =~ m/^_((.*)_(.*$))/) { # this a special case
my $table_name = get_table_names('creator_'.$2); #Bug 14143 fix to remove ambiguity with table 'club_template_enrollment_fields'
} elsif ( $table_column =~ m/^_((.*)_(.*$))/ ) { # this a special case
my $table_name = get_table_names( 'creator_' . $2 )
; #Bug 14143 fix to remove ambiguity with table 'club_template_enrollment_fields'
my $record_set = _SELECT( $1, @$table_name[0], $2 . "_id = " . $db_row->{ $2 . "_id" } );
$$fields[$col_index] = {hidden => 0, link_field => $link_field->{$table_column}, select_field => 0, field_name => ($table_column . "_tbl"), field_value => $$record_set[0]{$1}};
$$fields[$col_index] = {
hidden => 0, link_field => $link_field->{$table_column}, select_field => 0,
field_name => ( $table_column . "_tbl" ), field_value => $$record_set[0]{$1}
};
$col_index++;
next POPULATE_ROW;
}
elsif ($table_column eq 'select' ) {
$$fields[$col_index] = {hidden => 0, select_field => 1, field_name => 'select', field_value => $db_row->{$select_value}};
} elsif ( $table_column eq 'select' ) {
$$fields[$col_index] =
{ hidden => 0, select_field => 1, field_name => 'select', field_value => $db_row->{$select_value} };
}
}
$$table[$row_index] = { text_fields => $fields };

9
C4/Creators/PDF.pm
View File

@ -55,7 +55,6 @@ use PDF::Reuse::Barcode;
use File::Temp;
use List::Util qw( first );
sub _InitVars {
my $self = shift;
my $param = shift;
@ -191,8 +190,12 @@ sub Init {
sub AltJpeg {
my $self = shift;
my ($imageData, $width, $height, $imageFormat, $altImageData, $altImageWidth, $altImageHeight, $altImageFormat) = @_;
return prAltJpeg($imageData, $width, $height, $imageFormat, $altImageData, $altImageWidth, $altImageHeight, $altImageFormat);
my ( $imageData, $width, $height, $imageFormat, $altImageData, $altImageWidth, $altImageHeight, $altImageFormat ) =
@_;
return prAltJpeg(
$imageData, $width, $height, $imageFormat, $altImageData, $altImageWidth, $altImageHeight,
$altImageFormat
);
}
sub Jpeg {

23
C4/Creators/Profile.pm
View File

@ -8,7 +8,6 @@ use autouse 'Data::Dumper' => qw(Dumper);
use C4::Context;
use C4::Creators::Lib qw( get_unit_values );
sub _check_params {
my $given_params = {};
my $exit_code = 0;
@ -31,8 +30,7 @@ sub _check_params {
$exit_code = 1;
}
}
}
else {
} else {
if ( !( grep m/$_/, @valid_profile_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
@ -98,20 +96,22 @@ sub delete {
$self = shift; # check to see if this is a method call
$call_type = 'C4::' . $self->{'creator'} . '::Profile->delete';
push @params, $self->{'profile_id'}, $self->{'creator'};
}
else {
} else {
my $class = shift; #XXX: is this too hackish?
%opts = @_;
$call_type = $class . "::delete";
push @params, $opts{'profile_id'}, $opts{'creator'};
}
if ( scalar(@params) < 2 ) { # If there is no profile id or creator type then we cannot delete it
warn sprintf('%s : Cannot delete profile as the profile ID is invalid or non-existent.', $call_type) if !$params[0];
warn sprintf('%s : Cannot delete profile as the creator type is invalid or non-existent.', $call_type) if !$params[1];
warn sprintf( '%s : Cannot delete profile as the profile ID is invalid or non-existent.', $call_type )
if !$params[0];
warn sprintf( '%s : Cannot delete profile as the creator type is invalid or non-existent.', $call_type )
if !$params[1];
return -1;
}
my $query = "DELETE FROM printers_profile WHERE profile_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute(@params);
if ( $sth->err ) {
@ -135,6 +135,7 @@ sub save {
push( @params, $self->{'profile_id'}, $self->{'creator'} );
$query .= " WHERE profile_id=? AND creator=?;";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute(@params);
if ( $sth->err ) {
@ -142,8 +143,7 @@ sub save {
return -1;
}
return $self->{'profile_id'};
}
else { # otherwise create a new record
} else { # otherwise create a new record
my @params;
my $query = "INSERT INTO printers_profile (";
foreach my $key ( keys %{$self} ) {
@ -178,8 +178,7 @@ sub get_attr {
my ($attr) = @_;
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
warn sprintf( '%s is currently undefined.', $attr );
return -1;
}
@ -193,7 +192,7 @@ sub set_attr {
my %attrs = @_;
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
return 0;
}

66
C4/Creators/Template.pm
View File

@ -9,7 +9,6 @@ use C4::Context;
use C4::Creators::Profile;
use C4::Creators::Lib qw( get_unit_values );
sub _check_params {
shift if $_[0] =~ m/::/; # this seems a bit hackish
my $given_params = {};
@ -44,8 +43,7 @@ sub _check_params {
$exit_code = 1;
}
}
}
else {
} else {
if ( !( grep m/$_/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
@ -73,7 +71,8 @@ sub _conv_points {
sub _apply_profile {
my $self = shift;
my $creator = shift;
my $profile = C4::Creators::Profile->retrieve(profile_id => $self->{'profile_id'}, creator => $creator, convert => 1);
my $profile =
C4::Creators::Profile->retrieve( profile_id => $self->{'profile_id'}, creator => $creator, convert => 1 );
$self->{'top_margin'} = $self->{'top_margin'} + $profile->get_attr('offset_vert'); # controls vertical offset
$self->{'left_margin'} = $self->{'left_margin'} + $profile->get_attr('offset_horz'); # controls horizontal offset
$self->{'label_height'} = $self->{'label_height'} + $profile->get_attr('creep_vert'); # controls vertical creep
@ -124,7 +123,8 @@ sub retrieve {
}
my $self = $sth->fetchrow_hashref;
$self = _conv_points($self) if ( ( $opts{convert} && $opts{convert} == 1 ) || $opts{profile_id} );
$self = _apply_profile($self, $opts{'creator'}) if $opts{profile_id} && $self->{'profile_id'}; # don't bother if there is no profile_id
$self = _apply_profile( $self, $opts{'creator'} )
if $opts{profile_id} && $self->{'profile_id'}; # don't bother if there is no profile_id
$self->{'template_stat'} = 1;
bless( $self, $type );
return $self;
@ -139,15 +139,16 @@ sub delete {
$self = shift; # check to see if this is a method call
$call_type = 'C4::Labels::Template->delete';
push @query_params, $self->{'template_id'}, $self->{'creator'};
}
else {
} else {
%opts = @_;
$call_type = 'C4::Labels::Template::delete';
push @query_params, $opts{'template_id'}, $opts{'creator'};
}
if ( scalar(@query_params) < 2 ) { # If there is no template id or creator type then we cannot delete it
warn sprintf('%s : Cannot delete template as the template ID is invalid or non-existent.', $call_type) if !$query_params[0];
warn sprintf('%s : Cannot delete template as the creator type is invalid or non-existent.', $call_type) if !$query_params[1];
warn sprintf( '%s : Cannot delete template as the template ID is invalid or non-existent.', $call_type )
if !$query_params[0];
warn sprintf( '%s : Cannot delete template as the creator type is invalid or non-existent.', $call_type )
if !$query_params[1];
return -1;
}
my $query = "DELETE FROM creator_templates WHERE template_id = ? AND creator = ?";
@ -178,8 +179,7 @@ sub save {
}
$self->{'template_stat'} = 1;
return $self->{'template_id'};
}
else { # otherwise create a new record
} else { # otherwise create a new record
my @params;
my $query = "INSERT INTO " . $opts{'table_name'} . " (";
foreach my $key ( keys %{$self} ) {
@ -217,8 +217,7 @@ sub get_attr {
my ($attr) = @_;
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
}
@ -231,7 +230,7 @@ sub set_attr {
my %attrs = @_;
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
}
sub get_label_position {
@ -243,15 +242,27 @@ sub get_label_position {
$current_label->{'llx'} = $self->{'left_margin'};
$current_label->{'lly'} = ( $self->{'page_height'} - $self->{'top_margin'} - $self->{'label_height'} );
$self->{'current_label'} = $current_label;
return ($current_label->{'row_count'}, $current_label->{'col_count'}, $current_label->{'llx'}, $current_label->{'lly'});
}
else {
return (
$current_label->{'row_count'}, $current_label->{'col_count'}, $current_label->{'llx'},
$current_label->{'lly'}
);
} else {
$current_label->{'row_count'} = ceil( $start_label / $self->{'cols'} );
$current_label->{'col_count'} = ( $start_label - ( ( $current_label->{'row_count'} - 1 ) * $self->{'cols'} ) );
$current_label->{'llx'} = $self->{'left_margin'} + ($self->{'label_width'} * ($current_label->{'col_count'} - 1)) + ($self->{'col_gap'} * ($current_label->{'col_count'} - 1));
$current_label->{'lly'} = $self->{'page_height'} - $self->{'top_margin'} - ($self->{'label_height'} * $current_label->{'row_count'}) - ($self->{'row_gap'} * ($current_label->{'row_count'} - 1));
$current_label->{'llx'} =
$self->{'left_margin'} +
( $self->{'label_width'} * ( $current_label->{'col_count'} - 1 ) ) +
( $self->{'col_gap'} * ( $current_label->{'col_count'} - 1 ) );
$current_label->{'lly'} =
$self->{'page_height'} -
$self->{'top_margin'} -
( $self->{'label_height'} * $current_label->{'row_count'} ) -
( $self->{'row_gap'} * ( $current_label->{'row_count'} - 1 ) );
$self->{'current_label'} = $current_label;
return ($current_label->{'row_count'}, $current_label->{'col_count'}, $current_label->{'llx'}, $current_label->{'lly'});
return (
$current_label->{'row_count'}, $current_label->{'col_count'}, $current_label->{'llx'},
$current_label->{'lly'}
);
}
}
@ -260,18 +271,19 @@ sub get_next_label_pos {
my $current_label = $self->{'current_label'};
my $new_page = 0;
if ( $current_label->{'col_count'} lt $self->get_attr('cols') ) {
$current_label->{'llx'} = ($current_label->{'llx'} + $self->get_attr('label_width') + $self->get_attr('col_gap'));
$current_label->{'llx'} =
( $current_label->{'llx'} + $self->get_attr('label_width') + $self->get_attr('col_gap') );
$current_label->{'col_count'}++;
}
else {
} else {
$current_label->{'llx'} = $self->get_attr('left_margin');
if ( $current_label->{'row_count'} eq $self->get_attr('rows') ) {
$new_page = 1;
$current_label->{'lly'} = ($self->get_attr('page_height') - $self->get_attr('top_margin') - $self->get_attr('label_height'));
$current_label->{'lly'} =
( $self->get_attr('page_height') - $self->get_attr('top_margin') - $self->get_attr('label_height') );
$current_label->{'row_count'} = 1;
}
else {
$current_label->{'lly'} = ($current_label->{'lly'} - $self->get_attr('row_gap') - $self->get_attr('label_height'));
} else {
$current_label->{'lly'} =
( $current_label->{'lly'} - $self->get_attr('row_gap') - $self->get_attr('label_height') );
$current_label->{'row_count'}++;
}
$current_label->{'col_count'} = 1;

4
C4/External/Amazon.pm vendored
View File

@ -1,4 +1,5 @@
package C4::External::Amazon;
# Copyright (C) 2006 LibLime
# <jmf at liblime dot com>
#
@ -17,7 +18,6 @@ package C4::External::Amazon;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use strict;
use warnings;
@ -31,7 +31,6 @@ BEGIN {
);
}
sub get_amazon_tld {
my %tld = (
CA => '.ca',
@ -48,7 +47,6 @@ sub get_amazon_tld {
return $tld;
}
=head1 NAME
C4::External::Amazon - Functions for retrieving Amazon.com content in Koha

11
C4/External/BakerTaylor.pm vendored
View File

@ -42,8 +42,10 @@ sub _initialize {
$user = ( @_ ? shift : C4::Context->preference('BakerTaylorUsername') ) || ''; # LL17984
$pass = ( @_ ? shift : C4::Context->preference('BakerTaylorPassword') ) || ''; # CC82349
$link_url = ( @_ ? shift : C4::Context->preference('BakerTaylorBookstoreURL') );
$image_url = "https://contentcafe2.btol.com/ContentCafe/Jacket.aspx?UserID=$user&Password=$pass&Options=Y&Return=T&Type=S&Value=";
$image_url =
"https://contentcafe2.btol.com/ContentCafe/Jacket.aspx?UserID=$user&Password=$pass&Options=Y&Return=T&Type=S&Value=";
$agent = "Koha/$VERSION [en] (Linux)";
#"Mozilla/4.76 [en] (Win98; U)", # if for some reason you want to go stealth, you might prefer this
}
@ -68,7 +70,8 @@ sub content_cafe_url {
( $user and $pass ) or return;
my $isbn = ( @_ ? shift : '' );
$isbn =~ s/(p|-)//g; # sanitize
return "https://contentcafe2.btol.com/ContentCafeClient/ContentCafe.aspx?UserID=$user&Password=$pass&Options=Y&ItemKey=$isbn";
return
"https://contentcafe2.btol.com/ContentCafeClient/ContentCafe.aspx?UserID=$user&Password=$pass&Options=Y&ItemKey=$isbn";
}
sub http_jacket_link {
@ -88,11 +91,13 @@ sub availability {
my $isbn = shift or return;
( $user and $pass ) or return;
$isbn =~ s/(p|-)//g; # sanitize
my $url = "https://contentcafe2.btol.com/ContentCafe/InventoryAvailability.asmx/CheckInventory?UserID=$user&Password=$pass&Value=$isbn";
my $url =
"https://contentcafe2.btol.com/ContentCafe/InventoryAvailability.asmx/CheckInventory?UserID=$user&Password=$pass&Value=$isbn";
my $content = get($url);
warn "could not retrieve $url" unless $content;
my $xmlsimple = XML::Simple->new();
my $result = $xmlsimple->XMLin($content);
if ( $result->{Error} ) {
warn "Error returned to " . __PACKAGE__ . " : " . $result->{Error};
}

18
C4/External/OverDrive.pm vendored
View File

@ -41,9 +41,7 @@ sub _request {
my $ua = LWP::UserAgent->new( agent => "Koha " . $Koha::VERSION );
my $response;
eval {
$response = $ua->request( $request ) ;
};
eval { $response = $ua->request($request); };
if ($@) {
warn "OverDrive request failed: $@";
return;
@ -86,9 +84,8 @@ sub GetOverDriveToken {
my $token;
$cache and $token = $cache->get_from_cache("overdrive_token") and return $token;
my $request = HTTP::Request::Common::POST( 'https://oauth.overdrive.com/token', [
grant_type => 'client_credentials'
] ) ;
my $request =
HTTP::Request::Common::POST( 'https://oauth.overdrive.com/token', [ grant_type => 'client_credentials' ] );
$request->header( Authorization => LWP::Authen::Basic->auth_header( $key, $secret ) );
my $response = _request($request) or return;
@ -99,7 +96,8 @@ sub GetOverDriveToken {
my $contents = from_json( $response->decoded_content );
if ( !$response->is_success ) {
warn "Could not log into OverDrive: " . ( $contents ? $contents->{'error_description'} : $response->decoded_content );
warn "Could not log into OverDrive: "
. ( $contents ? $contents->{'error_description'} : $response->decoded_content );
return;
}
@ -107,8 +105,10 @@ sub GetOverDriveToken {
# Fudge factor to prevent spurious failures
$cache
and $cache->set_in_cache( 'overdrive_token', $token,
{ expiry => $contents->{'expires_in'} - 5 } );
and $cache->set_in_cache(
'overdrive_token', $token,
{ expiry => $contents->{'expires_in'} - 5 }
);
return $token;
}

23
C4/External/Syndetics.pm vendored
View File

@ -1,4 +1,5 @@
package C4::External::Syndetics;
# Copyright (C) 2006 LibLime
# <jmf at liblime dot com>
#
@ -77,7 +78,12 @@ sub get_syndetics_index {
) unless !$content;
my $syndetics_elements;
for my $available_type ('SUMMARY','TOC','FICTION','AWARDS1','SERIES1','SPSUMMARY','SPREVIEW', 'AVPROFILE', 'AVSUMMARY','DBCHAPTER','LJREVIEW','PWREVIEW','SLJREVIEW','CHREVIEW','BLREVIEW','HBREVIEW','KIREVIEW','CRITICASREVIEW','ANOTES') {
for my $available_type (
'SUMMARY', 'TOC', 'FICTION', 'AWARDS1', 'SERIES1', 'SPSUMMARY', 'SPREVIEW', 'AVPROFILE',
'AVSUMMARY', 'DBCHAPTER', 'LJREVIEW', 'PWREVIEW', 'SLJREVIEW', 'CHREVIEW', 'BLREVIEW', 'HBREVIEW', 'KIREVIEW',
'CRITICASREVIEW', 'ANOTES'
)
{
if ( exists $response->{$available_type} && $response->{$available_type} =~ /$available_type/ ) {
$syndetics_elements->{$available_type} = $available_type;
}
@ -122,6 +128,7 @@ sub get_syndetics_toc {
$content,
forcearray => [qw(Fld970)],
) unless !$content;
# manipulate response USMARC VarFlds VarDFlds Notes Fld520 a
my $toc;
$toc = \@{ $response->{VarFlds}->{VarDFlds}->{SSIFlds}->{Fld970} } if $response;
@ -142,6 +149,7 @@ sub get_syndetics_excerpt {
$content,
forcearray => [qw(Fld520)],
) unless !$content;
# manipulate response USMARC VarFlds VarDFlds Notes Fld520 a
my $excerpt;
$excerpt = \@{ $response->{VarFlds}->{VarDFlds}->{Notes}->{Fld520} } if $response;
@ -165,9 +173,12 @@ sub get_syndetics_reviews {
];
for my $source (@$review_sources) {
if ($syndetics_elements->{$source->{element}} and $source->{element} =~ $syndetics_elements->{$source->{element}}) {
if ( $syndetics_elements->{ $source->{element} }
and $source->{element} =~ $syndetics_elements->{ $source->{element} } )
{
} else {
#warn "Skipping $source->{element} doesn't match $syndetics_elements->{$source->{element}} \n";
next;
}
@ -212,6 +223,7 @@ sub get_syndetics_editions {
$content,
forcearray => [qw(Fld020)],
) unless !$content;
# manipulate response USMARC VarFlds VarDFlds Notes Fld520 a
my $similar_items;
$similar_items = \@{ $response->{VarFlds}->{VarDFlds}->{NumbCode}->{Fld020} } if $response;
@ -236,14 +248,14 @@ sub get_syndetics_anotes {
) unless !$content;
my @anotes;
for my $fld980 ( @{ $response->{VarFlds}->{VarDFlds}->{SSIFlds}->{Fld980} } ) {
# this is absurd, but sometimes this data serializes differently
if ( ref( $fld980->{a}->{content} ) eq 'ARRAY' ) {
for my $content ( @{ $fld980->{a}->{content} } ) {
push @anotes, { content => $content };
}
}
else {
} else {
push @anotes, { content => $fld980->{a}->{content} };
}
}
@ -259,7 +271,8 @@ sub _fetch_syndetics_content {
my $syndetics_client_code = C4::Context->preference('SyndeticsClientCode');
my $url = "http://www.syndetics.com/index.aspx?isbn=$isbn/$element&client=$syndetics_client_code&type=xw10&upc=$upc&oclc=$oclc";
my $url =
"http://www.syndetics.com/index.aspx?isbn=$isbn/$element&client=$syndetics_client_code&type=xw10&upc=$upc&oclc=$oclc";
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
$ua->env_proxy;

19
C4/Form/MessagingPreferences.pm
View File

@ -73,11 +73,14 @@ adds a settings_updated template variable.
sub handle_form_action {
my ( $query, $target_params, $template, $insert, $categorycode ) = @_;
my $messaging_options = C4::Members::Messaging::GetMessagingOptions();
# TODO: If a "NONE" box and another are checked somehow (javascript failed), we should pay attention to the "NONE" box
my $prefs_set = 0;
OPTION: foreach my $option (@$messaging_options) {
my $updater = { %{ $target_params },
message_attribute_id => $option->{'message_attribute_id'} };
my $updater = {
%{$target_params},
message_attribute_id => $option->{'message_attribute_id'}
};
# find the desired transports
@{ $updater->{'message_transport_types'} } = $query->multi_param( $option->{'message_attribute_id'} );
@ -97,6 +100,7 @@ sub handle_form_action {
C4::Members::Messaging::SetMessagingPreference($updater);
}
# show the success message
$template->param( settings_updated => 1 );
}
@ -117,18 +121,23 @@ C<$template> is the Template::Toolkit object for the response.
sub set_form_values {
my ( $target_params, $template ) = @_;
# walk through the options and update them with these borrower_preferences
my $messaging_options = C4::Members::Messaging::GetMessagingOptions();
PREF: foreach my $option (@$messaging_options) {
my $pref = C4::Members::Messaging::GetMessagingPreferences( { %{ $target_params }, message_name => $option->{'message_name'} } );
my $pref = C4::Members::Messaging::GetMessagingPreferences(
{ %{$target_params}, message_name => $option->{'message_name'} } );
$option->{ $option->{'message_name'} } = 1;
# make a hashref of the days, selecting one.
if ( $option->{'takes_days'} ) {
my $days_in_advance = $pref->{'days_in_advance'} ? $pref->{'days_in_advance'} : 0;
$option->{days_in_advance} = $days_in_advance;
@{$option->{'select_days'}} = map { {
@{ $option->{'select_days'} } = map {
{
day => $_,
selected => $_ == $days_in_advance }
selected => $_ == $days_in_advance
}
} ( 0 .. MAX_DAYS_IN_ADVANCE );
}
foreach my $transport ( keys %{ $pref->{'transports'} } ) {

109
C4/HTML5Media.pm
View File

@ -50,57 +50,57 @@ sub gethtml5media {
my @HTML5MediaExtensions = split( /\|/, C4::Context->preference("HTML5MediaExtensions") );
my $HTML5MediaYouTube = C4::Context->preference("HTML5MediaYouTube");
my $marcflavour = C4::Context->preference("marcflavour");
foreach my $HTML5Media_field (@HTML5Media_fields) {
my $is_youtube = 0;
my %HTML5Media;
# protocol
if ( $HTML5Media_field->indicator(1) eq '1' ) {
$HTML5Media{protocol} = 'ftp';
}
elsif ( $HTML5Media_field->indicator(1) eq '4' ) {
} elsif ( $HTML5Media_field->indicator(1) eq '4' ) {
$HTML5Media{protocol} = 'http';
}
elsif ( $HTML5Media_field->indicator(1) eq '7' ) {
} elsif ( $HTML5Media_field->indicator(1) eq '7' ) {
if ( $marcflavour eq 'MARC21' ) {
$HTML5Media{protocol} = $HTML5Media_field->subfield('2');
}
elsif ($marcflavour eq 'UNIMARC') {
} elsif ( $marcflavour eq 'UNIMARC' ) {
$HTML5Media{protocol} = $HTML5Media_field->subfield('y');
}
}
else {
} else {
$HTML5Media{protocol} = 'http';
}
# user
if ( $HTML5Media_field->subfield('l') ) {
$HTML5Media{username} = $HTML5Media_field->subfield('l'); # yes, that is arbitrary if h and l are not the same. originally i flipped a coin in that case.
}
elsif ( $HTML5Media_field->subfield('h') ) {
$HTML5Media{username} = $HTML5Media_field->subfield('l')
; # yes, that is arbitrary if h and l are not the same. originally i flipped a coin in that case.
} elsif ( $HTML5Media_field->subfield('h') ) {
$HTML5Media{username} = $HTML5Media_field->subfield('h');
}
# user/pass
if ( $HTML5Media{username} && $HTML5Media_field->subfield('k') ) {
$HTML5Media{loginblock} = $HTML5Media{username} . ':' . $HTML5Media_field->subfield('k') . '@';
}
elsif ( $HTML5Media{username} ) {
} elsif ( $HTML5Media{username} ) {
$HTML5Media{loginblock} = $HTML5Media{username} . '@';
}
else {
} else {
$HTML5Media{loginblock} = '';
}
# port
if ( $HTML5Media_field->subfield('p') ) {
$HTML5Media{portblock} = ':' . $HTML5Media_field->subfield('k');
}
else {
} else {
$HTML5Media{portblock} = '';
}
# src
if ( $HTML5Media_field->subfield('u') ) {
$HTML5Media{srcblock} = $HTML5Media_field->subfield('u');
if ( grep /youtu\.?be/, $HTML5Media_field->subfield('u') ) {
if ( $HTML5MediaYouTube == 1 ) {
my $url = $HTML5Media_field->subfield('u');
# Credit for regex goes to https://stackoverflow.com/questions/3452546/how-do-i-get-the-youtube-video-id-from-a-url
next unless $url =~ m{^.*(youtu\.be\/|v\/|u\/\w\/|embed\/|watch\?v=|\&v=)([^#\&\?]*).*};
my $video_id = $2;
@ -108,35 +108,46 @@ sub gethtml5media {
$HTML5Media{srcblock} = sprintf 'https://www.youtube.com/embed/%s', $video_id;
$HTML5Media{is_youtube} = 1;
$is_youtube = 1;
}
else {
} else {
next; # do not embed youtube videos
}
}
}
elsif ( $HTML5Media_field->subfield('a') && $HTML5Media_field->subfield('d') && $HTML5Media_field->subfield('f') ) {
} elsif ( $HTML5Media_field->subfield('a')
&& $HTML5Media_field->subfield('d')
&& $HTML5Media_field->subfield('f') )
{
$HTML5Media{host} = $HTML5Media_field->subfield('a');
$HTML5Media{host} =~ s/(^\/|\/$)//g;
$HTML5Media{path} = $HTML5Media_field->subfield('d');
$HTML5Media{path} =~ s/(^\/|\/$)//g; # TODO we could check for youtube here too, but nobody uses these fields anyway…
$HTML5Media{path} =~
s/(^\/|\/$)//g; # TODO we could check for youtube here too, but nobody uses these fields anyway…
$HTML5Media{file} = $HTML5Media_field->subfield('f');
$HTML5Media{srcblock} = $HTML5Media{protocol} . '://' . $HTML5Media{loginblock} . $HTML5Media{host} . $HTML5Media{portblock} . '/' . $HTML5Media{path} . '/' . $HTML5Media{file};
}
else {
$HTML5Media{srcblock} =
$HTML5Media{protocol} . '://'
. $HTML5Media{loginblock}
. $HTML5Media{host}
. $HTML5Media{portblock} . '/'
. $HTML5Media{path} . '/'
. $HTML5Media{file};
} else {
next; # no file to play
}
# extension
# check uploaded files
if ( $HTML5Media{srcblock} =~ /\Qopac-retrieve-file.pl\E/ ) {
my ( undef, $id ) = split /id=/, $HTML5Media{srcblock};
next if !$id;
my %public = ( (caller)[1] =~ /opac/ ) ? ( public => 1 ) : ();
my $upload = Koha::UploadedFiles->search({
my $upload = Koha::UploadedFiles->search(
{
hashvalue => $id, %public,
})->next;
}
)->next;
next if !$upload || $upload->filename !~ /\./;
$HTML5Media{extension} = ( $upload->filename =~ m/([^.]+)$/ )[0];
}
# check remote files
else {
$HTML5Media{extension} = ( $HTML5Media{srcblock} =~ m/([^.]+)$/ )[0];
@ -144,11 +155,13 @@ sub gethtml5media {
if ( ( !grep /\Q$HTML5Media{extension}\E/, @HTML5MediaExtensions ) && ( $is_youtube != 1 ) ) {
next; # not a specified media file
}
# youtube
if ( $is_youtube == 1 ) {
$HTML5Media{mime} = 'video/webm';
$HTML5Media{type} = 'video';
}
# mime
if ( $HTML5Media_field->subfield('c') ) {
$HTML5Media{codecs} = $HTML5Media_field->subfield('c');
@ -161,14 +174,11 @@ sub gethtml5media {
elsif ( $HTML5Media{codecs} ) {
if ( $HTML5Media{codecs} =~ /theora.*vorbis/ ) {
$HTML5Media{mime} = 'video/ogg';
}
elsif ( $HTML5Media{codecs} =~ /vp8.*vorbis/ ) {
} elsif ( $HTML5Media{codecs} =~ /vp8.*vorbis/ ) {
$HTML5Media{mime} = 'video/webm';
}
elsif ( ($HTML5Media{codecs} =~ /^vorbis$/) && ($HTML5Media{extension} eq 'ogg') ) {
} elsif ( ( $HTML5Media{codecs} =~ /^vorbis$/ ) && ( $HTML5Media{extension} eq 'ogg' ) ) {
$HTML5Media{mime} = 'audio/ogg';
}
elsif ( ($HTML5Media{codecs} =~ /^vorbis$/) && ($HTML5Media{extension} eq 'webm') ) {
} elsif ( ( $HTML5Media{codecs} =~ /^vorbis$/ ) && ( $HTML5Media{extension} eq 'webm' ) ) {
$HTML5Media{mime} = 'audio/webm';
}
}
@ -181,48 +191,46 @@ sub gethtml5media {
if ( $HTML5Media{extension} eq 'oga' ) {
$HTML5Media{mime} = 'audio/ogg';
$HTML5Media{codecs} = 'vorbis';
}
elsif ( $HTML5Media{extension} eq 'spx' ) {
} elsif ( $HTML5Media{extension} eq 'spx' ) {
$HTML5Media{mime} = 'audio/ogg';
$HTML5Media{codecs} = 'speex';
}
elsif ( $HTML5Media{extension} eq 'opus' ) {
} elsif ( $HTML5Media{extension} eq 'opus' ) {
$HTML5Media{mime} = 'audio/ogg';
$HTML5Media{codecs} = 'opus';
}
elsif ( $HTML5Media{extension} eq 'vtt' ) {
} elsif ( $HTML5Media{extension} eq 'vtt' ) {
$HTML5Media{mime} = 'text/vtt';
}
}
# codecs
if ( $HTML5Media{codecs} ) {
$HTML5Media{codecblock} = '; codecs="' . $HTML5Media{codecs} . '"';
}
else {
} else {
$HTML5Media{codecblock} = '';
}
# type
if ( $HTML5Media{mime} ) {
$HTML5Media{typeblock} = ' type=\'' . $HTML5Media{mime} . $HTML5Media{codecblock} . '\'';
}
else {
} else {
$HTML5Media{typeblock} = '';
}
# element
if ( $HTML5Media{mime} =~ /audio/ ) {
$HTML5Media{type} = 'audio';
}
elsif ( $HTML5Media{mime} =~ /video/ ) {
} elsif ( $HTML5Media{mime} =~ /video/ ) {
$HTML5Media{type} = 'video';
}
elsif ( $HTML5Media{mime} =~ /text/ ) {
} elsif ( $HTML5Media{mime} =~ /text/ ) {
$HTML5Media{type} = 'track';
}
# push
if ( $HTML5Media{srcblock} && $HTML5Media{type} ) {
push( @HTML5Media_sets, \%HTML5Media );
}
}
# parent element
for my $media (@HTML5Media_sets) {
if ( ( $media->{mime} ) && ( $media->{mime} =~ /audio/ ) ) {
@ -230,20 +238,19 @@ sub gethtml5media {
$HTML5MediaParent = 'audio';
$HTML5MediaWidth = '';
}
}
elsif ( ($media->{mime}) && ($media->{mime} =~ /video/) ) {
} elsif ( ( $media->{mime} ) && ( $media->{mime} =~ /video/ ) ) {
$HTML5MediaParent = 'video';
$HTML5MediaWidth = ' width="480"';
}
}
# child element
for my $media (@HTML5Media_sets) {
if ( ( $media->{type} ) && ( ( $media->{type} eq 'video' ) || ( $media->{type} eq 'audio' ) ) ) {
if ( $media->{type} eq $HTML5MediaParent ) {
$media->{child} = 'source';
}
}
else {
} else {
$media->{child} = $media->{type};
}
}

17
C4/Heading.pm
View File

@ -212,10 +212,8 @@ sub _search {
# Use state variables to avoid recreating the objects every time.
# With Elasticsearch this also avoids creating a massive amount of
# ES connectors that would eventually run out of file descriptors.
state $builder = Koha::SearchEngine::QueryBuilder->new(
{ index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
state $searcher = Koha::SearchEngine::Search->new(
{index => $Koha::SearchEngine::AUTHORITIES_INDEX} );
state $builder = Koha::SearchEngine::QueryBuilder->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
state $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
my $search_query = $builder->build_authorities_query_compat(
\@marclist, \@and_or, \@excluding, \@operator,
@ -224,6 +222,7 @@ sub _search {
);
my ( $matched_auths, $total ) = $searcher->search_auth_compat( $search_query, 0, 20, $skipmetadata );
# Some auth records may not contain the 040$f to specify their source
# This is legal, so we do a fallback search
if (
@ -239,12 +238,12 @@ sub _search {
{
pop @value;
push @value, 'notdefined';
$search_query =
$builder->build_authorities_query_compat( \@marclist, \@and_or,
$search_query = $builder->build_authorities_query_compat(
\@marclist, \@and_or,
\@excluding, \@operator, \@value, $self->{'auth_type'},
'AuthidAsc' );
( $matched_auths, $total ) =
$searcher->search_auth_compat( $search_query, 0, 20, $skipmetadata );
'AuthidAsc'
);
( $matched_auths, $total ) = $searcher->search_auth_compat( $search_query, 0, 20, $skipmetadata );
}
return ( $matched_auths, $total );

55
C4/Heading/MARC21.pm
View File

@ -21,7 +21,6 @@ use strict;
use warnings;
use MARC::Field;
=head1 NAME
C4::Heading::MARC21
@ -158,10 +157,8 @@ my $bib_heading_fields = {
subfields => 'abcdfghklmnoprst',
series => 1
},
'811' =>
{ auth_type => 'MEETI_NAME', subfields => 'acdefghklnpqst', series => 1 },
'830' =>
{ auth_type => 'UNIF_TITLE', subfields => 'adfghklmnoprst', series => 1 },
'811' => { auth_type => 'MEETI_NAME', subfields => 'acdefghklnpqst', series => 1 },
'830' => { auth_type => 'UNIF_TITLE', subfields => 'adfghklmnoprst', series => 1 },
};
my $auth_heading_fields = {
@ -270,8 +267,7 @@ sub valid_heading_tag {
if ( exists $heading_fields->{$tag} ) {
return 1;
}
else {
} else {
return 0;
}
@ -340,12 +336,12 @@ sub parse_heading {
$tag =~ m/6../
? _get_subject_thesaurus($field)
: undef; # We can't know the thesaurus for non-subject fields
my $search_heading =
_get_search_heading( $field, $field_info->{'subfields'} );
my $display_heading =
_get_display_heading( $field, $field_info->{'subfields'} );
return ( $auth_type, $thesaurus, $search_heading, $display_heading,
'exact' );
my $search_heading = _get_search_heading( $field, $field_info->{'subfields'} );
my $display_heading = _get_display_heading( $field, $field_info->{'subfields'} );
return (
$auth_type, $thesaurus, $search_heading, $display_heading,
'exact'
);
}
=head1 INTERNAL FUNCTIONS
@ -366,26 +362,19 @@ sub _get_subject_thesaurus {
my $thesaurus = "notdefined";
if ( $ind2 eq '0' ) {
$thesaurus = "lcsh";
}
elsif ( $ind2 eq '1' ) {
} elsif ( $ind2 eq '1' ) {
$thesaurus = "lcac";
}
elsif ( $ind2 eq '2' ) {
} elsif ( $ind2 eq '2' ) {
$thesaurus = "mesh";
}
elsif ( $ind2 eq '3' ) {
} elsif ( $ind2 eq '3' ) {
$thesaurus = "nal";
}
elsif ( $ind2 eq '4' ) {
} elsif ( $ind2 eq '4' ) {
$thesaurus = "notspecified";
}
elsif ( $ind2 eq '5' ) {
} elsif ( $ind2 eq '5' ) {
$thesaurus = "cash";
}
elsif ( $ind2 eq '6' ) {
} elsif ( $ind2 eq '6' ) {
$thesaurus = "rvm";
}
elsif ( $ind2 eq '7' ) {
} elsif ( $ind2 eq '7' ) {
my $sf2 = $field->subfield('2');
$thesaurus = $sf2 if defined($sf2);
}
@ -415,12 +404,10 @@ sub _get_search_heading {
if ($first) {
$first = 0;
$heading = $value;
}
else {
} else {
if ( exists $subdivisions{$code} ) {
$heading .= " $subdivisions{$code} $value";
}
else {
} else {
$heading .= " $value";
}
}
@ -453,12 +440,10 @@ sub _get_display_heading {
if ($first) {
$first = 0;
$heading = $value;
}
else {
} else {
if ( exists $subdivisions{$code} ) {
$heading .= "--$value";
}
else {
} else {
$heading .= " $value";
}
}

19
C4/Heading/UNIMARC.pm
View File

@ -23,7 +23,6 @@ use warnings;
use MARC::Field;
use C4::Context;
=head1 NAME
C4::Heading::UNIMARC
@ -122,10 +121,8 @@ sub parse_heading {
my $tag = $field->tag;
my $field_info = $bib_heading_fields->{$tag};
my $auth_type = $field_info->{'auth_type'};
my $search_heading =
_get_search_heading( $field, $field_info->{'subfields'} );
my $display_heading =
_get_display_heading( $field, $field_info->{'subfields'} );
my $search_heading = _get_search_heading( $field, $field_info->{'subfields'} );
my $display_heading = _get_display_heading( $field, $field_info->{'subfields'} );
return ( $auth_type, undef, $search_heading, $display_heading, 'exact' );
}
@ -166,12 +163,10 @@ sub _get_search_heading {
if ($first) {
$first = 0;
$heading = $value;
}
else {
} else {
if ( exists $subdivisions{$code} ) {
$heading .= " $subdivisions{$code} $value";
}
else {
} else {
$heading .= " $value";
}
}
@ -202,12 +197,10 @@ sub _get_display_heading {
if ($first) {
$first = 0;
$heading = $value;
}
else {
} else {
if ( exists $subdivisions{$code} ) {
$heading .= "--$value";
}
else {
} else {
$heading .= " $value";
}
}

73
C4/HoldsQueue.pm
View File

@ -36,6 +36,7 @@ use List::MoreUtils qw( any );
use Algorithm::Munkres qw();
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -51,7 +52,6 @@ BEGIN {
);
}
=head1 FUNCTIONS
=head2 TransportCostMatrix
@ -97,7 +97,8 @@ sub UpdateTransportCostMatrix {
my ($records) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("INSERT INTO transport_cost (frombranch, tobranch, cost, disable_transfer) VALUES (?, ?, ?, ?)");
my $sth =
$dbh->prepare("INSERT INTO transport_cost (frombranch, tobranch, cost, disable_transfer) VALUES (?, ?, ?, ?)");
$dbh->do("DELETE FROM transport_cost");
foreach (@$records) {
@ -106,8 +107,7 @@ sub UpdateTransportCostMatrix {
my $to = $_->{tobranch};
if ( $_->{disable_transfer} ) {
$cost ||= 0;
}
elsif ( !defined ($cost) || ($cost !~ m/(0|[1-9][0-9]*)(\.[0-9]*)?/o) ) {
} elsif ( !defined($cost) || ( $cost !~ m/(0|[1-9][0-9]*)(\.[0-9]*)?/o ) ) {
warn "Invalid $from -> $to cost $cost - must be a number >= 0, disabling";
$cost = 0;
$_->{disable_transfer} = 1;
@ -143,11 +143,7 @@ sub GetHoldsQueueItems {
prefetch => [
'biblio',
'biblioitem',
{
'item' => {
'item_group_item' => 'item_group'
}
}
{ 'item' => { 'item_group_item' => 'item_group' } }
],
order_by => [
'ccode', 'location', 'item.cn_sort', 'author',
@ -242,7 +238,6 @@ sub CreateQueue {
}
}
=head2 GetBibsWithPendingHoldRequests
my $biblionumber_aref = GetBibsWithPendingHoldRequests();
@ -384,11 +379,13 @@ sub GetItemsAvailableToFillHoldRequestsForBib {
$sth->execute(@params);
my $itm = $sth->fetchall_arrayref( {} );
return [ grep {
return [
grep {
my $rule = C4::Circulation::GetBranchItemRule( $_->{homebranch}, $_->{itype} );
$_->{holdallowed} = $rule->{holdallowed};
$_->{hold_fulfillment_policy} = $rule->{hold_fulfillment_policy};
} @{$itm} ];
} @{$itm}
];
}
=head2 _checkHoldPolicy
@ -602,6 +599,7 @@ RETRY:
for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
for ( my $j = 0 ; $j < $num_tasks ; $j++ ) {
if ( $m[$i][$j] < 0 ) {
# Bias towards not allocating items to holds closer to
# the end of the queue in the queue if not all holds
# can be filled by representing infinity with
@ -735,10 +733,8 @@ sub MapItemsToHoldRequests {
# Look for Local Holds Priority matches first
if ( C4::Context->preference('LocalHoldsPriority') ) {
my $LocalHoldsPriorityPatronControl =
C4::Context->preference('LocalHoldsPriorityPatronControl');
my $LocalHoldsPriorityItemControl =
C4::Context->preference('LocalHoldsPriorityItemControl');
my $LocalHoldsPriorityPatronControl = C4::Context->preference('LocalHoldsPriorityPatronControl');
my $LocalHoldsPriorityItemControl = C4::Context->preference('LocalHoldsPriorityItemControl');
foreach my $request (@$hold_requests) {
last if $num_items_remaining == 0;
@ -753,19 +749,14 @@ sub MapItemsToHoldRequests {
next if $request->{itemnumber} && $request->{itemnumber} != $item->{itemnumber};
my $local_holds_priority_item_branchcode =
$item->{$LocalHoldsPriorityItemControl};
my $local_holds_priority_item_branchcode = $item->{$LocalHoldsPriorityItemControl};
my $local_holds_priority_patron_branchcode =
( $LocalHoldsPriorityPatronControl eq 'PickupLibrary' )
? $request->{branchcode}
: ( $LocalHoldsPriorityPatronControl eq 'HomeLibrary' )
? $request->{borrowerbranch}
( $LocalHoldsPriorityPatronControl eq 'PickupLibrary' ) ? $request->{branchcode}
: ( $LocalHoldsPriorityPatronControl eq 'HomeLibrary' ) ? $request->{borrowerbranch}
: undef;
$local_hold_match =
$local_holds_priority_item_branchcode eq
$local_holds_priority_patron_branchcode;
$local_hold_match = $local_holds_priority_item_branchcode eq $local_holds_priority_patron_branchcode;
if ($local_hold_match) {
if ( exists $items_by_itemnumber{ $item->{itemnumber} }
@ -802,6 +793,7 @@ sub MapItemsToHoldRequests {
# is this an item-level request?
if ( defined( $request->{itemnumber} ) ) {
# fill it if possible; if not skip it
if ( exists $items_by_itemnumber{ $request->{itemnumber} }
and not exists $allocated_items{ $request->{itemnumber} }
@ -822,6 +814,7 @@ sub MapItemsToHoldRequests {
$num_items_remaining--;
}
} else {
# it's title-level request that will take up one item
$num_items_remaining--;
}
@ -880,10 +873,10 @@ sub MapItemsToHoldRequests {
last;
}
}
# End HoldsQueuePrioritizeBranch check
# ********************************
# Not found yet, fall back to basics
unless ($itemnumber) {
if ($branches_to_use) {
@ -962,7 +955,6 @@ sub MapItemsToHoldRequests {
return \%item_map;
}
=head2 _can_item_fill_request
my $bool = _can_item_fill_request( $item, $request, $libraries );
@ -996,8 +988,6 @@ sub _can_item_fill_request {
return 1;
}
=head2 CreatePickListFromItemMap
=cut
@ -1037,9 +1027,11 @@ sub CreatePicklistFromItemMap {
my $biblio = Koha::Biblios->find($biblionumber);
my $title = $biblio->title;
$sth_load->execute($biblionumber, $itemnumber, $barcode, $surname, $firstname, $phone, $borrowernumber,
$sth_load->execute(
$biblionumber, $itemnumber, $barcode, $surname, $firstname, $phone, $borrowernumber,
$cardnumber, $reservedate, $title, $itemcallnumber,
$holdingbranch, $pickbranch, $reservenotes, $item_level);
$holdingbranch, $pickbranch, $reservenotes, $item_level
);
}
}
@ -1092,9 +1084,7 @@ sub load_branches_to_pull_from {
if $static_branch_list;
}
@branches_to_use =
Koha::Database->new()->schema()->resultset('Branch')
->get_column('branchcode')->all()
@branches_to_use = Koha::Database->new()->schema()->resultset('Branch')->get_column('branchcode')->all()
unless (@branches_to_use);
@branches_to_use = shuffle(@branches_to_use)
@ -1102,10 +1092,7 @@ sub load_branches_to_pull_from {
my $today = dt_from_string();
if ( C4::Context->preference('HoldsQueueSkipClosed') ) {
@branches_to_use = grep {
!Koha::Calendar->new( branchcode => $_ )
->is_holiday( $today )
} @branches_to_use;
@branches_to_use = grep { !Koha::Calendar->new( branchcode => $_ )->is_holiday($today) } @branches_to_use;
}
return \@branches_to_use;
@ -1217,16 +1204,20 @@ sub update_queue_for_biblio {
$dbh->do("DELETE FROM hold_fill_targets WHERE biblionumber=$biblio_id");
}
my $hold_requests = GetPendingHoldRequestsForBib({ biblionumber => $biblio_id, unallocated => $args->{unallocated} });
my $hold_requests =
GetPendingHoldRequestsForBib( { biblionumber => $biblio_id, unallocated => $args->{unallocated} } );
$result->{requests} = scalar( @{$hold_requests} );
# No need to check anything else if there are no holds to fill
return $result unless $result->{requests};
my $branches_to_use = $args->{branches_to_use} // load_branches_to_pull_from( C4::Context->preference('UseTransportCostMatrix') );
my $branches_to_use = $args->{branches_to_use}
// load_branches_to_pull_from( C4::Context->preference('UseTransportCostMatrix') );
my $transport_cost_matrix;
if ( !exists $args->{transport_cost_matrix}
&& C4::Context->preference('UseTransportCostMatrix') ) {
&& C4::Context->preference('UseTransportCostMatrix') )
{
$transport_cost_matrix = TransportCostMatrix();
} else {
$transport_cost_matrix = $args->{transport_cost_matrix};

54
C4/ILSDI/Services.pm
View File

@ -130,7 +130,10 @@ sub GetAvailability {
$out .= " <dlf:availabilitystatus>" . $status . "</dlf:availabilitystatus>\n";
if ($msg) { $out .= " <dlf:availabilitymsg>" . $msg . "</dlf:availabilitymsg>\n"; }
if ($location) { $out .= " <dlf:location>" . $location . "</dlf:location>\n"; }
if ($itemcallnumber) { $out .= " <dlf:itemcallnumber>" . $itemcallnumber. "</dlf:itemcallnumber>\n"; }
if ($itemcallnumber) {
$out .= " <dlf:itemcallnumber>" . $itemcallnumber . "</dlf:itemcallnumber>\n";
}
$out .= " </dlf:simpleavailability>\n";
$out .= " </dlf:item>\n";
$out .= " </dlf:items>\n";
@ -140,10 +143,12 @@ sub GetAvailability {
my $msg;
my $items = Koha::Items->search( { biblionumber => $id } );
if ( $items->count ) {
# Open XML
$out .= " <dlf:record>\n";
$out .= " <dlf:bibliographic id=\"" . $id . "\" />\n";
$out .= " <dlf:items>\n";
# We loop over the items to clean them
while ( my $item = $items->next ) {
my $itemnumber = $item->itemnumber;
@ -154,10 +159,14 @@ sub GetAvailability {
$out .= " <dlf:availabilitystatus>" . $status . "</dlf:availabilitystatus>\n";
if ($msg) { $out .= " <dlf:availabilitymsg>" . $msg . "</dlf:availabilitymsg>\n"; }
if ($location) { $out .= " <dlf:location>" . $location . "</dlf:location>\n"; }
if ($itemcallnumber) { $out .= " <dlf:itemcallnumber>" . $itemcallnumber. "</dlf:itemcallnumber>\n"; }
if ($itemcallnumber) {
$out .= " <dlf:itemcallnumber>" . $itemcallnumber . "</dlf:itemcallnumber>\n";
}
$out .= " </dlf:simpleavailability>\n";
$out .= " </dlf:item>\n";
}
# Close XML
$out .= " </dlf:items>\n";
$out .= " </dlf:record>\n";
@ -254,7 +263,8 @@ sub GetRecords {
$item{'holdingbranchname'} = $holding_library ? $holding_library->branchname : '';
if ( $item->location ) {
my $authorised_value = Koha::AuthorisedValues->get_description_by_koha_field({frameworkcode => '', kohafield => 'items.location', authorised_value => $item->location });
my $authorised_value = Koha::AuthorisedValues->get_description_by_koha_field(
{ frameworkcode => '', kohafield => 'items.location', authorised_value => $item->location } );
if ($authorised_value) {
$item{location_description} = $authorised_value->{opac_description};
}
@ -363,8 +373,11 @@ sub LookupPatron {
if ($passed_id_type) {
$patrons = Koha::Patrons->search( { $passed_id_type => $id } );
} else {
foreach my $id_type ('cardnumber', 'userid', 'email', 'borrowernumber',
'surname', 'firstname') {
foreach my $id_type (
'cardnumber', 'userid', 'email', 'borrowernumber',
'surname', 'firstname'
)
{
$patrons = Koha::Patrons->search( { $id_type => $id } );
last if ( $patrons->count );
}
@ -396,14 +409,13 @@ sub AuthenticatePatron {
my $password = $cgi->param('password');
my ( $status, $cardnumber, $userid, $patron ) = C4::Auth::checkpw( $username, $password );
if ( $status == 1 ) {
# Track the login
$patron->update_lastseen('connection');
return { id => $patron->borrowernumber };
}
elsif ( $status == -2 ){
} elsif ( $status == -2 ) {
return { code => 'PasswordExpired' };
}
else {
} else {
return { code => 'PatronNotFound' };
}
}
@ -442,7 +454,8 @@ sub GetPatronInfo {
# Cleaning the borrower hashref
my $borrower = $patron->unblessed;
$borrower->{charges} = sprintf "%.02f", $patron->account->non_issues_charges; # FIXME Formatting should not be done here
$borrower->{charges} = sprintf "%.02f",
$patron->account->non_issues_charges; # FIXME Formatting should not be done here
my $library = Koha::Libraries->find( $borrower->{branchcode} );
$borrower->{'branchname'} = $library ? $library->branchname : '';
delete $borrower->{'userid'};
@ -456,7 +469,8 @@ sub GetPatronInfo {
'email', 'emailpro', 'fax', 'mobile', 'phone', 'phonepro',
'streetnumber', 'zipcode', 'city', 'streettype', 'B_address', 'B_city',
'B_email', 'B_phone', 'B_zipcode', 'address', 'address2', 'altcontactaddress1',
'altcontactaddress2', 'altcontactaddress3', 'altcontactfirstname', 'altcontactphone', 'altcontactsurname', 'altcontactzipcode'
'altcontactaddress2', 'altcontactaddress3', 'altcontactfirstname', 'altcontactphone', 'altcontactsurname',
'altcontactzipcode'
);
# and delete them
@ -478,6 +492,7 @@ sub GetPatronInfo {
while ( my $hold = $holds->next ) {
my ( $item, $biblio, $biblioitem ) = ( {}, {}, {} );
# Get additional informations
if ( $hold->itemnumber ) { # item level holds
$item = Koha::Items->find( $hold->itemnumber );
@ -516,14 +531,18 @@ sub GetPatronInfo {
$page ||= 1;
$per_page ||= 10;
$borrower->{total_loans} = $pending_checkouts->count();
$pending_checkouts = $pending_checkouts->search(undef, {
$pending_checkouts = $pending_checkouts->search(
undef,
{
rows => $per_page,
page => $page,
});
}
);
}
my @checkouts;
while ( my $c = $pending_checkouts->next ) {
# FIXME We should only retrieve what is needed in the template
my $issue = $c->unblessed_all_relateds;
delete $issue->{'more_subfields_xml'};
@ -534,13 +553,14 @@ sub GetPatronInfo {
# Is the record (next available item) on hold by another user?
$issue->{'holds_on_record'} = Koha::Holds->search( { biblionumber => $issue->{'biblionumber'} } )->count;
push @checkouts, $issue
push @checkouts, $issue;
}
$borrower->{'loans'}->{'loan'} = \@checkouts;
}
my $show_attributes = $cgi->param('show_attributes');
if ( $show_attributes && $show_attributes eq "1" ) {
# FIXME Regression expected here, we do not retrieve the same field as previously
# Waiting for answer on bug 14257 comment 15
$borrower->{'attributes'} = [
@ -613,6 +633,7 @@ sub GetServices {
return { code => 'PatronNotFound' } unless $patron;
my $borrower = $patron->unblessed;
# Get the item, or return an error code if not found
my $itemnumber = $cgi->param('item_id');
my $item = Koha::Items->find($itemnumber);
@ -709,6 +730,7 @@ sub RenewLoan {
# Hashref building
my $out;
$out->{'renewals'} = $issue->renewals_count;
# FIXME Unusual date formatting
$out->{date_due} = dt_from_string( $issue->date_due )->strftime('%Y-%m-%d %H:%M');
$out->{'success'} = $renewal[0];
@ -746,7 +768,6 @@ sub HoldTitle {
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# If borrower is restricted return an error code
return { code => 'PatronRestricted' } if $patron->is_debarred;
@ -765,7 +786,8 @@ sub HoldTitle {
push( @itemnumbers, @hostitems );
}
my $items = Koha::Items->search({ -or => { biblionumber => $biblionumber, itemnumber => { in => \@itemnumbers } } });
my $items =
Koha::Items->search( { -or => { biblionumber => $biblionumber, itemnumber => { in => \@itemnumbers } } } );
unless ( $items->count ) {
return { code => 'NoItems' };

297
C4/ImportBatch.pm
View File

@ -32,7 +32,8 @@ use C4::Biblio qw(
);
use C4::Items qw( AddItemFromMarc ModItemFromMarc );
use C4::Charset qw( MarcToUTF8Record SetUTF8Flag StripNonXmlChars );
use C4::AuthoritiesMarc qw( AddAuthority GuessAuthTypeCode GetAuthorityXML ModAuthority DelAuthority GetAuthorizedHeading );
use C4::AuthoritiesMarc
qw( AddAuthority GuessAuthTypeCode GetAuthorityXML ModAuthority DelAuthority GetAuthorizedHeading );
use C4::MarcModificationTemplates qw( ModifyRecordWithTemplate );
use Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue;
use Koha::Items;
@ -42,6 +43,7 @@ use Koha::Plugins::Handler;
use Koha::Logger;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -119,21 +121,25 @@ sub GetZ3950BatchId {
my ($z3950server) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT import_batch_id FROM import_batches
my $sth = $dbh->prepare(
"SELECT import_batch_id FROM import_batches
WHERE batch_type = 'z3950'
AND file_name = ?");
AND file_name = ?"
);
$sth->execute($z3950server);
my $rowref = $sth->fetchrow_arrayref();
$sth->finish();
if ( defined $rowref ) {
return $rowref->[0];
} else {
my $batch_id = AddImportBatch( {
my $batch_id = AddImportBatch(
{
overlay_action => 'create_new',
import_status => 'staged',
batch_type => 'z3950',
file_name => $z3950server,
} );
}
);
return $batch_id;
}
@ -153,6 +159,7 @@ SELECT import_batch_id FROM import_batches
WHERE batch_type = 'webservice'
AND import_status = 'staged'
EOQ
sub GetWebserviceBatchId {
my ($params) = @_;
@ -183,11 +190,13 @@ sub GetImportRecordMarc {
my ($import_record_id) = @_;
my $dbh = C4::Context->dbh;
my ( $marc, $encoding ) = $dbh->selectrow_array(q|
my ( $marc, $encoding ) = $dbh->selectrow_array(
q|
SELECT marc, encoding
FROM import_records
WHERE import_record_id = ?
|, undef, $import_record_id );
|, undef, $import_record_id
);
return $marc, $encoding;
}
@ -202,19 +211,24 @@ sub AddImportBatch {
my ($params) = @_;
my ( @fields, @vals );
foreach (qw( matcher_id template_id branchcode
foreach (
qw( matcher_id template_id branchcode
overlay_action nomatch_action item_action
import_status batch_type file_name comments record_type )) {
import_status batch_type file_name comments record_type )
)
{
if ( exists $params->{$_} ) {
push @fields, $_;
push @vals, $params->{$_};
}
}
my $dbh = C4::Context->dbh;
$dbh->do("INSERT INTO import_batches (".join( ',', @fields).")
$dbh->do(
"INSERT INTO import_batches (" . join( ',', @fields ) . ")
VALUES (" . join( ',', map '?', @fields ) . ")",
undef,
@vals);
@vals
);
return $dbh->{'mysql_insertid'};
}
@ -230,7 +244,9 @@ sub GetImportBatch {
my ($batch_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare_cached("SELECT b.*, p.name as profile FROM import_batches b LEFT JOIN import_batch_profiles p ON p.id = b.profile_id WHERE import_batch_id = ?");
my $sth = $dbh->prepare_cached(
"SELECT b.*, p.name as profile FROM import_batches b LEFT JOIN import_batch_profiles p ON p.id = b.profile_id WHERE import_batch_id = ?"
);
$sth->bind_param( 1, $batch_id );
$sth->execute();
my $result = $sth->fetchrow_hashref;
@ -253,7 +269,10 @@ sub AddBiblioToBatch {
my $encoding = shift;
my $update_counts = @_ ? shift : 1;
my $import_record_id = _create_import_record($batch_id, $record_sequence, $marc_record, 'biblio', $encoding, C4::Context->preference('marcflavour'));
my $import_record_id = _create_import_record(
$batch_id, $record_sequence, $marc_record, 'biblio', $encoding,
C4::Context->preference('marcflavour')
);
_add_biblio_fields( $import_record_id, $marc_record );
_update_batch_record_counts($batch_id) if $update_counts;
return $import_record_id;
@ -276,7 +295,8 @@ sub AddAuthToBatch {
$marc_type = 'UNIMARCAUTH' if $marc_type eq 'UNIMARC';
my $import_record_id = _create_import_record($batch_id, $record_sequence, $marc_record, 'auth', $encoding, $marc_type);
my $import_record_id =
_create_import_record( $batch_id, $record_sequence, $marc_record, 'auth', $encoding, $marc_type );
_add_auth_fields( $import_record_id, $marc_record );
_update_batch_record_counts($batch_id) if $update_counts;
return $import_record_id;
@ -318,26 +338,28 @@ sub BatchStageMarcRecords {
$progress_interval = 0 unless 'CODE' eq ref $progress_callback;
}
my $batch_id = AddImportBatch( {
my $batch_id = AddImportBatch(
{
overlay_action => 'create_new',
import_status => 'staging',
batch_type => 'batch',
file_name => $file_name,
comments => $comments,
record_type => $record_type,
} );
}
);
if ($parse_items) {
SetImportBatchItemAction( $batch_id, 'always_add' );
} else {
SetImportBatchItemAction( $batch_id, 'ignore' );
}
my $marc_type = C4::Context->preference('marcflavour');
$marc_type .= 'AUTH' if ( $marc_type eq 'UNIMARC' && $record_type eq 'auth' );
my @invalid_records = ();
my $num_valid = 0;
my $num_items = 0;
# FIXME - for now, we're dealing only with bibs
my $rec_num = 0;
foreach my $marc_record (@$marc_records) {
@ -371,6 +393,7 @@ sub BatchStageMarcRecords {
unless ($leave_as_staging) {
SetImportBatchStatus( $batch_id, 'staged' );
}
# FIXME branch_code, number of bibs, number of items
_update_batch_record_counts($batch_id);
if ($progress_interval) {
@ -402,8 +425,10 @@ sub AddItemsToImportBiblio {
$item_marc->leader("00000 a "); # must set Leader/09 to 'a'
$item_marc->append_fields($item_field);
$marc_record->delete_field($item_field);
my $sth = $dbh->prepare_cached("INSERT INTO import_items (import_record_id, status, marcxml)
VALUES (?, ?, ?)");
my $sth = $dbh->prepare_cached(
"INSERT INTO import_items (import_record_id, status, marcxml)
VALUES (?, ?, ?)"
);
$sth->bind_param( 1, $import_record_id );
$sth->bind_param( 2, 'staged' );
$sth->bind_param( 3, $item_marc->as_xml("USMARC") );
@ -456,9 +481,11 @@ sub BatchFindDuplicates {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT import_record_id, record_type, marc
my $sth = $dbh->prepare(
"SELECT import_record_id, record_type, marc
FROM import_records
WHERE import_batch_id = ?");
WHERE import_batch_id = ?"
);
$sth->execute($batch_id);
my $num_with_matches = 0;
my $rec_num = 0;
@ -524,6 +551,7 @@ sub BatchCommitRecords {
my $num_items_replaced = 0;
my $num_items_errored = 0;
my $num_ignored = 0;
# commit (i.e., save, all records in the batch)
my $overlay_action = GetImportBatchOverlayAction($batch_id);
my $nomatch_action = GetImportBatchNoMatchAction($batch_id);
@ -531,11 +559,13 @@ sub BatchCommitRecords {
my $item_tag;
my $item_subfield;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT import_records.import_record_id, record_type, status, overlay_status, marc, encoding
my $sth = $dbh->prepare(
"SELECT import_records.import_record_id, record_type, status, overlay_status, marc, encoding
FROM import_records
LEFT JOIN import_auths ON (import_records.import_record_id=import_auths.import_record_id)
LEFT JOIN import_biblios ON (import_records.import_record_id=import_biblios.import_record_id)
WHERE import_batch_id = ?");
WHERE import_batch_id = ?"
);
$sth->execute($batch_id);
my $marcflavour = C4::Context->preference('marcflavour');
@ -552,6 +582,7 @@ sub BatchCommitRecords {
$rec_num++;
if ( $progress_interval and ( 0 == ( $rec_num % $progress_interval ) ) ) {
# report progress
&$progress_callback($rec_num);
}
@ -571,6 +602,7 @@ sub BatchCommitRecords {
my $marc_record = MARC::Record->new_from_usmarc( $rowref->{'marc'} );
if ( $record_type eq 'biblio' ) {
# remove any item tags - rely on _batchCommitItems
( $item_tag, $item_subfield ) = &GetMarcFromKohaField("items.itemnumber");
foreach my $item_field ( $marc_record->field($item_tag) ) {
@ -582,9 +614,10 @@ sub BatchCommitRecords {
}
}
my ($record_result, $item_result, $record_match) =
_get_commit_action($overlay_action, $nomatch_action, $item_action,
$rowref->{'overlay_status'}, $rowref->{'import_record_id'}, $record_type);
my ( $record_result, $item_result, $record_match ) = _get_commit_action(
$overlay_action, $nomatch_action, $item_action,
$rowref->{'overlay_status'}, $rowref->{'import_record_id'}, $record_type
);
my $recordid;
my $query;
@ -594,9 +627,11 @@ sub BatchCommitRecords {
my $biblioitemnumber;
( $recordid, $biblioitemnumber ) = AddBiblio( $marc_record, $framework, { skip_record_index => 1 } );
push @biblio_ids, $recordid if $recordid;
$query = "UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?"; # FIXME call SetMatchedBiblionumber instead
$query = "UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?"
; # FIXME call SetMatchedBiblionumber instead
if ( $item_result eq 'create_new' || $item_result eq 'replace' ) {
my ($bib_items_added, $bib_items_replaced, $bib_items_errored) = _batchCommitItems($rowref->{'import_record_id'}, $recordid, $item_result, $biblioitemnumber);
my ( $bib_items_added, $bib_items_replaced, $bib_items_errored ) =
_batchCommitItems( $rowref->{'import_record_id'}, $recordid, $item_result, $biblioitemnumber );
$num_items_added += $bib_items_added;
$num_items_replaced += $bib_items_replaced;
$num_items_errored += $bib_items_errored;
@ -620,7 +655,8 @@ sub BatchCommitRecords {
# remove item fields so that they don't get
# added again if record is reverted
# FIXME: GetXmlBiblio output should not contain item info any more! So the next foreach should not be needed. Does not hurt either; may remove old 952s that should not have been there anymore.
my $old_marc = MARC::Record->new_from_xml(StripNonXmlChars($oldxml), 'UTF-8', $rowref->{'encoding'}, $marc_type);
my $old_marc =
MARC::Record->new_from_xml( StripNonXmlChars($oldxml), 'UTF-8', $rowref->{'encoding'}, $marc_type );
foreach my $item_field ( $old_marc->field($item_tag) ) {
$old_marc->delete_field($item_field);
}
@ -644,10 +680,12 @@ sub BatchCommitRecords {
);
push @biblio_ids, $recordid;
push @updated_ids, $recordid;
$query = "UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?"; # FIXME call SetMatchedBiblionumber instead
$query = "UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?"
; # FIXME call SetMatchedBiblionumber instead
if ( $item_result eq 'create_new' || $item_result eq 'replace' ) {
my ($bib_items_added, $bib_items_replaced, $bib_items_errored) = _batchCommitItems($rowref->{'import_record_id'}, $recordid, $item_result);
my ( $bib_items_added, $bib_items_replaced, $bib_items_errored ) =
_batchCommitItems( $rowref->{'import_record_id'}, $recordid, $item_result );
$num_items_added += $bib_items_added;
$num_items_replaced += $bib_items_replaced;
$num_items_errored += $bib_items_errored;
@ -658,8 +696,10 @@ sub BatchCommitRecords {
ModAuthority( $recordid, $marc_record, GuessAuthTypeCode($marc_record) );
$query = "UPDATE import_auths SET matched_authid = ? WHERE import_record_id = ?";
}
# Combine xml update, SetImportRecordOverlayStatus, and SetImportRecordStatus updates into a single update for efficiency, especially in a transaction
my $sth = $dbh->prepare_cached("UPDATE import_records SET marcxml_old = ?, status = ?, overlay_status = ? WHERE import_record_id = ?");
my $sth = $dbh->prepare_cached(
"UPDATE import_records SET marcxml_old = ?, status = ?, overlay_status = ? WHERE import_record_id = ?");
$sth->execute( $oldxml, 'imported', 'match_applied', $rowref->{'import_record_id'} );
$sth->finish();
my $sth2 = $dbh->prepare_cached($query);
@ -668,15 +708,22 @@ sub BatchCommitRecords {
} elsif ( $record_result eq 'ignore' ) {
$recordid = $record_match;
$num_ignored++;
if ($record_type eq 'biblio' and defined $recordid and ( $item_result eq 'create_new' || $item_result eq 'replace' ) ) {
my ($bib_items_added, $bib_items_replaced, $bib_items_errored) = _batchCommitItems($rowref->{'import_record_id'}, $recordid, $item_result);
if ( $record_type eq 'biblio'
and defined $recordid
and ( $item_result eq 'create_new' || $item_result eq 'replace' ) )
{
my ( $bib_items_added, $bib_items_replaced, $bib_items_errored ) =
_batchCommitItems( $rowref->{'import_record_id'}, $recordid, $item_result );
push @biblio_ids, $recordid if $bib_items_added || $bib_items_replaced;
$num_items_added += $bib_items_added;
$num_items_replaced += $bib_items_replaced;
$num_items_errored += $bib_items_errored;
# still need to record the matched biblionumber so that the
# items can be reverted
my $sth2 = $dbh->prepare_cached("UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?"); # FIXME call SetMatchedBiblionumber instead
my $sth2 = $dbh->prepare_cached(
"UPDATE import_biblios SET matched_biblionumber = ? WHERE import_record_id = ?")
; # FIXME call SetMatchedBiblionumber instead
$sth2->execute( $recordid, $rowref->{'import_record_id'} );
SetImportRecordOverlayStatus( $rowref->{'import_record_id'}, 'match_applied' );
}
@ -693,7 +740,6 @@ sub BatchCommitRecords {
SetImportBatchStatus( $batch_id, 'imported' );
if (@biblio_ids) {
my $indexer = Koha::SearchEngine::Indexer->new( { index => $Koha::SearchEngine::BIBLIOS_INDEX } );
$indexer->index_records( \@biblio_ids, "specialUpdate", "biblioserver" );
@ -733,13 +779,15 @@ sub _batchCommitItems {
$sth->execute();
while ( my $row = $sth->fetchrow_hashref() ) {
my $item_marc = MARC::Record->new_from_xml( StripNonXmlChars( $row->{'marcxml'} ), 'UTF-8', $row->{'encoding'} );
my $item_marc =
MARC::Record->new_from_xml( StripNonXmlChars( $row->{'marcxml'} ), 'UTF-8', $row->{'encoding'} );
# Delete date_due subfield as to not accidentally delete item checkout due dates
my ( $MARCfield, $MARCsubfield ) = GetMarcFromKohaField('items.onloan');
$item_marc->field($MARCfield)->delete_subfield( code => $MARCsubfield );
my $item = TransformMarcToKoha({ record => $item_marc, kohafields => ['items.barcode','items.itemnumber'] });
my $item =
TransformMarcToKoha( { record => $item_marc, kohafields => [ 'items.barcode', 'items.itemnumber' ] } );
my $item_match;
my $duplicate_barcode = exists( $item->{'barcode'} );
@ -747,12 +795,12 @@ sub _batchCommitItems {
# We assume that when replacing items we do not want to move them - the onus is on the importer to
# ensure the correct items/records are being updated
my $updsth = $dbh->prepare("UPDATE import_items SET status = ?, itemnumber = ?, import_error = ? WHERE import_items_id = ?");
if (
$action eq "replace" &&
$duplicate_itemnumber &&
( $item_match = Koha::Items->find( $item->{itemnumber} ))
) {
my $updsth = $dbh->prepare(
"UPDATE import_items SET status = ?, itemnumber = ?, import_error = ? WHERE import_items_id = ?");
if ( $action eq "replace"
&& $duplicate_itemnumber
&& ( $item_match = Koha::Items->find( $item->{itemnumber} ) ) )
{
# Duplicate itemnumbers have precedence, that way we can update barcodes by overlaying
ModItemFromMarc( $item_marc, $item_match->biblionumber, $item->{itemnumber}, { skip_record_index => 1 } );
$updsth->bind_param( 1, 'imported' );
@ -762,12 +810,14 @@ sub _batchCommitItems {
$updsth->execute();
$updsth->finish();
$num_items_replaced++;
} elsif (
$action eq "replace" &&
$duplicate_barcode &&
( $item_match = Koha::Items->find({ barcode => $item->{'barcode'} }) )
) {
ModItemFromMarc( $item_marc, $item_match->biblionumber, $item_match->itemnumber, { skip_record_index => 1 } );
} elsif ( $action eq "replace"
&& $duplicate_barcode
&& ( $item_match = Koha::Items->find( { barcode => $item->{'barcode'} } ) ) )
{
ModItemFromMarc(
$item_marc, $item_match->biblionumber, $item_match->itemnumber,
{ skip_record_index => 1 }
);
$updsth->bind_param( 1, 'imported' );
$updsth->bind_param( 2, $item->{itemnumber} );
$updsth->bind_param( 3, undef );
@ -776,10 +826,11 @@ sub _batchCommitItems {
$updsth->finish();
$num_items_replaced++;
} elsif (
# We aren't replacing, but the incoming file has a barcode, we need to check if it exists
$duplicate_barcode &&
( $item_match = Koha::Items->find({ barcode => $item->{'barcode'} }) )
) {
$duplicate_barcode && ( $item_match = Koha::Items->find( { barcode => $item->{'barcode'} } ) )
)
{
$updsth->bind_param( 1, 'error' );
$updsth->bind_param( 2, undef );
$updsth->bind_param( 3, 'duplicate item barcode' );
@ -787,11 +838,15 @@ sub _batchCommitItems {
$updsth->execute();
$num_items_errored++;
} else {
# Remove the itemnumber if it exists, we want to create a new item
my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField("items.itemnumber");
$item_marc->field($itemtag)->delete_subfield( code => $itemsubfield );
my ( $item_biblionumber, $biblioitemnumber, $itemnumber ) = AddItemFromMarc( $item_marc, $biblionumber, { biblioitemnumber => $biblioitemnumber, skip_record_index => 1 } );
my ( $item_biblionumber, $biblioitemnumber, $itemnumber ) = AddItemFromMarc(
$item_marc, $biblionumber,
{ biblioitemnumber => $biblioitemnumber, skip_record_index => 1 }
);
if ($itemnumber) {
$updsth->bind_param( 1, 'imported' );
$updsth->bind_param( 2, $itemnumber );
@ -827,19 +882,23 @@ sub BatchRevertRecords {
my $num_reverted = 0;
my $num_ignored = 0;
my $num_items_deleted = 0;
# commit (i.e., save, all records in the batch)
SetImportBatchStatus( $batch_id, 'reverting' );
my $overlay_action = GetImportBatchOverlayAction($batch_id);
my $nomatch_action = GetImportBatchNoMatchAction($batch_id);
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT import_records.import_record_id, record_type, status, overlay_status, marcxml_old, encoding, matched_biblionumber, matched_authid
my $sth = $dbh->prepare(
"SELECT import_records.import_record_id, record_type, status, overlay_status, marcxml_old, encoding, matched_biblionumber, matched_authid
FROM import_records
LEFT JOIN import_auths ON (import_records.import_record_id=import_auths.import_record_id)
LEFT JOIN import_biblios ON (import_records.import_record_id=import_biblios.import_record_id)
WHERE import_batch_id = ?");
WHERE import_batch_id = ?"
);
$sth->execute($batch_id);
my $marc_type;
my $marcflavour = C4::Context->preference('marcflavour');
while ( my $rowref = $sth->fetchrow_hashref ) {
$record_type = $rowref->{'record_type'};
if ( $rowref->{'status'} eq 'error' or $rowref->{'status'} eq 'reverted' ) {
@ -859,7 +918,8 @@ sub BatchRevertRecords {
if ( $record_result eq 'delete' ) {
my $error = undef;
if ( $record_type eq 'biblio' ) {
$num_items_deleted += BatchRevertItems($rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'});
$num_items_deleted +=
BatchRevertItems( $rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'} );
$error = DelBiblio( $rowref->{'matched_biblionumber'} );
} else {
DelAuthority( { authid => $rowref->{'matched_authid'} } );
@ -872,15 +932,21 @@ sub BatchRevertRecords {
}
} elsif ( $record_result eq 'restore' ) {
$num_reverted++;
my $old_record = MARC::Record->new_from_xml(StripNonXmlChars($rowref->{'marcxml_old'}), 'UTF-8', $rowref->{'encoding'}, $marc_type);
my $old_record = MARC::Record->new_from_xml(
StripNonXmlChars( $rowref->{'marcxml_old'} ), 'UTF-8',
$rowref->{'encoding'}, $marc_type
);
if ( $record_type eq 'biblio' ) {
my $biblionumber = $rowref->{'matched_biblionumber'};
my $oldbiblio = Koha::Biblios->find($biblionumber);
$logger->info("C4::ImportBatch::BatchRevertRecords: Biblio record $biblionumber does not exist, restoration of this record was skipped") unless $oldbiblio;
$logger->info(
"C4::ImportBatch::BatchRevertRecords: Biblio record $biblionumber does not exist, restoration of this record was skipped"
) unless $oldbiblio;
next unless $oldbiblio; # Record has since been deleted. Deleted records should stay deleted.
$num_items_deleted += BatchRevertItems($rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'});
$num_items_deleted +=
BatchRevertItems( $rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'} );
ModBiblio( $old_record, $biblionumber, $oldbiblio->frameworkcode );
} else {
my $authid = $rowref->{'matched_authid'};
@ -889,15 +955,19 @@ sub BatchRevertRecords {
SetImportRecordStatus( $rowref->{'import_record_id'}, 'reverted' );
} elsif ( $record_result eq 'ignore' ) {
if ( $record_type eq 'biblio' ) {
$num_items_deleted += BatchRevertItems($rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'});
$num_items_deleted +=
BatchRevertItems( $rowref->{'import_record_id'}, $rowref->{'matched_biblionumber'} );
}
SetImportRecordStatus( $rowref->{'import_record_id'}, 'reverted' );
}
my $query;
if ( $record_type eq 'biblio' ) {
# remove matched_biblionumber only if there is no 'imported' item left
$query = "UPDATE import_biblios SET matched_biblionumber = NULL WHERE import_record_id = ?"; # FIXME Remove me
$query = "UPDATE import_biblios SET matched_biblionumber = NULL WHERE import_record_id = ? AND NOT EXISTS (SELECT * FROM import_items WHERE import_items.import_record_id=import_biblios.import_record_id and status='imported')";
$query =
"UPDATE import_biblios SET matched_biblionumber = NULL WHERE import_record_id = ?"; # FIXME Remove me
$query =
"UPDATE import_biblios SET matched_biblionumber = NULL WHERE import_record_id = ? AND NOT EXISTS (SELECT * FROM import_items WHERE import_items.import_record_id=import_biblios.import_record_id and status='imported')";
} else {
$query = "UPDATE import_auths SET matched_authid = NULL WHERE import_record_id = ?";
}
@ -922,10 +992,12 @@ sub BatchRevertItems {
my $dbh = C4::Context->dbh;
my $num_items_deleted = 0;
my $sth = $dbh->prepare_cached("SELECT import_items_id, itemnumber
my $sth = $dbh->prepare_cached(
"SELECT import_items_id, itemnumber
FROM import_items
JOIN items USING (itemnumber)
WHERE import_record_id = ?");
WHERE import_record_id = ?"
);
$sth->bind_param( 1, $import_record_id );
$sth->execute();
while ( my $row = $sth->fetchrow_hashref() ) {
@ -937,8 +1009,7 @@ sub BatchRevertItems {
$updsth->execute();
$updsth->finish();
$num_items_deleted++;
}
else {
} else {
next;
}
}
@ -995,9 +1066,11 @@ ascending order by import_batch_id.
sub GetAllImportBatches {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare_cached("SELECT * FROM import_batches
my $sth = $dbh->prepare_cached(
"SELECT * FROM import_batches
WHERE batch_type IN ('batch', 'webservice')
ORDER BY import_batch_id ASC");
ORDER BY import_batch_id ASC"
);
my $results = [];
$sth->execute();
@ -1022,6 +1095,7 @@ SELECT import_batch_id FROM import_batches
WHERE batch_type = 'webservice'
AND import_status = 'staged'
EOQ
sub GetStagedWebserviceBatches {
my $dbh = C4::Context->dbh;
return $dbh->selectcol_arrayref($PENDING_WEBSERVICE_BATCHES_QRY);
@ -1135,10 +1209,10 @@ sub GetImportRecordsRange {
my $dbh = C4::Context->dbh;
my $order_by = $parameters->{order_by} || 'import_record_id';
( $order_by ) = grep( { $_ eq $order_by } qw( import_record_id title status overlay_status ) ) ? $order_by : 'import_record_id';
($order_by) =
grep( { $_ eq $order_by } qw( import_record_id title status overlay_status ) ) ? $order_by : 'import_record_id';
my $order_by_direction =
uc( $parameters->{order_by_direction} // 'ASC' ) eq 'DESC' ? 'DESC' : 'ASC';
my $order_by_direction = uc( $parameters->{order_by_direction} // 'ASC' ) eq 'DESC' ? 'DESC' : 'ASC';
$order_by .= " $order_by_direction, authorized_heading" if $order_by eq 'title';
@ -1184,7 +1258,8 @@ sub GetBestRecordMatch {
my ($import_record_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT candidate_match_id
my $sth = $dbh->prepare(
"SELECT candidate_match_id
FROM import_record_matches
JOIN import_records ON ( import_record_matches.import_record_id = import_records.import_record_id )
LEFT JOIN biblio ON ( candidate_match_id = biblio.biblionumber )
@ -1193,7 +1268,8 @@ sub GetBestRecordMatch {
( (import_records.record_type = 'biblio' AND biblio.biblionumber IS NOT NULL) OR
(import_records.record_type = 'auth' AND auth_header.authid IS NOT NULL) )
AND chosen = 1
ORDER BY score DESC, candidate_match_id DESC");
ORDER BY score DESC, candidate_match_id DESC"
);
$sth->execute($import_record_id);
my ($record_id) = $sth->fetchrow_array();
$sth->finish();
@ -1268,7 +1344,6 @@ sub GetImportBatchOverlayAction {
}
=head2 SetImportBatchOverlayAction
SetImportBatchOverlayAction($batch_id, $new_overlay_action);
@ -1303,7 +1378,6 @@ sub GetImportBatchNoMatchAction {
}
=head2 SetImportBatchNoMatchAction
SetImportBatchNoMatchAction($batch_id, $new_nomatch_action);
@ -1338,7 +1412,6 @@ sub GetImportBatchItemAction {
}
=head2 SetImportBatchItemAction
SetImportBatchItemAction($batch_id, $new_item_action);
@ -1373,7 +1446,6 @@ sub GetImportBatchMatcher {
}
=head2 SetImportBatchMatcher
SetImportBatchMatcher($batch_id, $new_matcher_id);
@ -1408,7 +1480,6 @@ sub GetImportRecordOverlayStatus {
}
=head2 SetImportRecordOverlayStatus
SetImportRecordOverlayStatus($import_record_id, $new_overlay_status);
@ -1443,7 +1514,6 @@ sub GetImportRecordStatus {
}
=head2 SetImportRecordStatus
SetImportRecordStatus($import_record_id, $new_status);
@ -1471,15 +1541,18 @@ sub GetImportRecordMatches {
my $best_only = @_ ? shift : 0;
my $dbh = C4::Context->dbh;
# FIXME currently biblio only
my $sth = $dbh->prepare_cached("SELECT title, author, biblionumber,
my $sth = $dbh->prepare_cached(
"SELECT title, author, biblionumber,
candidate_match_id, score, record_type,
chosen
FROM import_records
JOIN import_record_matches USING (import_record_id)
LEFT JOIN biblio ON (biblionumber = candidate_match_id)
WHERE import_record_id = ?
ORDER BY score DESC, biblionumber DESC");
ORDER BY score DESC, biblionumber DESC"
);
$sth->bind_param( 1, $import_record_id );
my $results = [];
$sth->execute();
@ -1512,8 +1585,10 @@ sub SetImportRecordMatches {
$delsth->execute($import_record_id);
$delsth->finish();
my $sth = $dbh->prepare("INSERT INTO import_record_matches (import_record_id, candidate_match_id, score, chosen)
VALUES (?, ?, ?, ?)");
my $sth = $dbh->prepare(
"INSERT INTO import_record_matches (import_record_id, candidate_match_id, score, chosen)
VALUES (?, ?, ?, ?)"
);
my $chosen = 1; #The first match is defaulted to be chosen
foreach my $match (@matches) {
$sth->execute( $import_record_id, $match->{'record_id'}, $match->{'score'}, $chosen );
@ -1611,11 +1686,13 @@ sub RecordsFromMarcPlugin {
close $fh;
# Convert to large MARC blob with plugin
$text = Koha::Plugins::Handler->run({
$text = Koha::Plugins::Handler->run(
{
class => $plugin_class,
method => 'to_marc',
params => { data => $text },
}) if $text;
}
) if $text;
# Convert to array of MARC records
if ($text) {
@ -1635,11 +1712,15 @@ sub _create_import_record {
my ( $batch_id, $record_sequence, $marc_record, $record_type, $encoding, $marc_type ) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("INSERT INTO import_records (import_batch_id, record_sequence, marc, marcxml, marcxml_old,
my $sth = $dbh->prepare(
"INSERT INTO import_records (import_batch_id, record_sequence, marc, marcxml, marcxml_old,
record_type, encoding)
VALUES (?, ?, ?, ?, ?, ?, ?)");
$sth->execute($batch_id, $record_sequence, $marc_record->as_usmarc(), $marc_record->as_xml($marc_type), '',
$record_type, $encoding);
VALUES (?, ?, ?, ?, ?, ?, ?)"
);
$sth->execute(
$batch_id, $record_sequence, $marc_record->as_usmarc(), $marc_record->as_xml($marc_type), '',
$record_type, $encoding
);
my $import_record_id = $dbh->{'mysql_insertid'};
$sth->finish();
return $import_record_id;
@ -1654,7 +1735,8 @@ sub _add_auth_fields {
}
my $authorized_heading = GetAuthorizedHeading( { record => $marc_record } );
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("INSERT INTO import_auths (import_record_id, control_number, authorized_heading) VALUES (?, ?, ?)");
my $sth = $dbh->prepare(
"INSERT INTO import_auths (import_record_id, control_number, authorized_heading) VALUES (?, ?, ?)");
$sth->execute( $import_record_id, $controlnumber, $authorized_heading );
$sth->finish();
}
@ -1664,9 +1746,11 @@ sub _add_biblio_fields {
my ( $title, $author, $isbn, $issn ) = _parse_biblio_fields($marc_record);
my $dbh = C4::Context->dbh;
# FIXME no controlnumber, originalsource
$isbn = C4::Koha::GetNormalizedISBN($isbn);
my $sth = $dbh->prepare("INSERT INTO import_biblios (import_record_id, title, author, isbn, issn) VALUES (?, ?, ?, ?, ?)");
my $sth = $dbh->prepare(
"INSERT INTO import_biblios (import_record_id, title, author, isbn, issn) VALUES (?, ?, ?, ?, ?)");
$sth->execute( $import_record_id, $title, $author, $isbn, $issn ) or die $sth->errstr;
$sth->finish();
@ -1677,13 +1761,16 @@ sub _update_biblio_fields {
my ( $title, $author, $isbn, $issn ) = _parse_biblio_fields($marc_record);
my $dbh = C4::Context->dbh;
# FIXME no controlnumber, originalsource
# FIXME 2 - should regularize normalization of ISBN wherever it is done
$isbn =~ s/\(.*$//;
$isbn =~ tr/ -_//;
$isbn = uc $isbn;
my $sth = $dbh->prepare("UPDATE import_biblios SET title = ?, author = ?, isbn = ?, issn = ?
WHERE import_record_id = ?");
my $sth = $dbh->prepare(
"UPDATE import_biblios SET title = ?, author = ?, isbn = ?, issn = ?
WHERE import_record_id = ?"
);
$sth->execute( $title, $author, $isbn, $issn, $import_record_id );
$sth->finish();
}
@ -1692,7 +1779,12 @@ sub _parse_biblio_fields {
my ($marc_record) = @_;
my $dbh = C4::Context->dbh;
my $bibliofields = TransformMarcToKoha({ record => $marc_record, kohafields => ['biblio.title','biblio.author','biblioitems.isbn','biblioitems.issn'] });
my $bibliofields = TransformMarcToKoha(
{
record => $marc_record,
kohafields => [ 'biblio.title', 'biblio.author', 'biblioitems.isbn', 'biblioitems.issn' ]
}
);
return ( $bibliofields->{'title'}, $bibliofields->{'author'}, $bibliofields->{'isbn'}, $bibliofields->{'issn'} );
}
@ -1701,17 +1793,21 @@ sub _update_batch_record_counts {
my ($batch_id) = @_;
my $dbh = C4::Context->dbh;
my ( $num_records ) = $dbh->selectrow_array(q|
my ($num_records) = $dbh->selectrow_array(
q|
SELECT COUNT(*)
FROM import_records
WHERE import_batch_id = ?
|, undef, $batch_id );
my ( $num_items ) = $dbh->selectrow_array(q|
|, undef, $batch_id
);
my ($num_items) = $dbh->selectrow_array(
q|
SELECT COUNT(*)
FROM import_records
JOIN import_items USING (import_record_id)
WHERE import_batch_id = ? AND record_type = 'biblio'
|, undef, $batch_id );
|, undef, $batch_id
);
$dbh->do(
"UPDATE import_batches SET num_records=?, num_items=? WHERE import_batch_id=?",
undef,
@ -1742,7 +1838,8 @@ sub _get_commit_action {
} else {
$bib_result = $nomatch_action;
$item_result = ($item_action eq 'always_add' or $item_action eq 'add_only_for_new') ? 'create_new' : 'ignore';
$item_result =
( $item_action eq 'always_add' or $item_action eq 'add_only_for_new' ) ? 'create_new' : 'ignore';
}
return ( $bib_result, $item_result, $bib_match );
} else { # must be auths

253
C4/ImportExportFramework.pm
View File

@ -30,6 +30,7 @@ use C4::Context;
use Koha::Logger;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -40,7 +41,6 @@ BEGIN {
);
}
use constant XMLSTR => '<?xml version="1.0" encoding="UTF-8"?>
<?mso-application progid="Excel.Sheet"?>
<Workbook
@ -74,7 +74,6 @@ use constant XMLSTR => '<?xml version="1.0" encoding="UTF-8"?>
</Workbook>
';
use constant ODSSTR => '<?xml version="1.0" encoding="UTF-8"?>
<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" office:version="1.0">
<office:scripts/>
@ -82,7 +81,6 @@ use constant ODSSTR => '<?xml version="1.0" encoding="UTF-8"?>
<office:automatic-styles/>
</office:document-content>';
use constant ODS_STYLES_STR => '<?xml version="1.0" encoding="UTF-8"?>
<office:document-styles xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" office:version="1.0">
<office:font-face-decls></office:font-face-decls>
@ -91,7 +89,6 @@ use constant ODS_STYLES_STR => '<?xml version="1.0" encoding="UTF-8"?>
<office:master-styles></office:master-styles>
</office:document-styles>';
use constant ODS_SETTINGS_STR => '<?xml version="1.0" encoding="UTF-8"?>
<office:document-settings xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:config="urn:oasis:names:tc:opendocument:xmlns:config:1.0" xmlns:ooo="http://openoffice.org/2004/office" office:version="1.0"><office:settings>
<config:config-item-set config:name="ooo:view-settings">
@ -147,7 +144,6 @@ use constant ODS_SETTINGS_STR => '<?xml version="1.0" encoding="UTF-8"?>
</config:config-item-set>
</office:settings></office:document-settings>';
use constant ODS_MANIFEST_STR => '<?xml version="1.0" encoding="UTF-8"?>
<manifest:manifest xmlns:manifest="urn:oasis:names:tc:opendocument:xmlns:manifest:1.0">
<manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.spreadsheet" manifest:full-path="/"/>
@ -168,7 +164,6 @@ use constant ODS_MANIFEST_STR => '<?xml version="1.0" encoding="UTF-8"?>
<manifest:file-entry manifest:media-type="text/xml" manifest:full-path="settings.xml"/>
</manifest:manifest>';
=head1 NAME
C4::ImportExportFramework - Import/Export Framework to Excel-xml/ODS Module Functions
@ -200,8 +195,7 @@ succes
=cut
sub ExportFramework
{
sub ExportFramework {
my ( $frameworkcode, $xmlStrRef, $mode, $frameworktype ) = @_;
my $dbh = C4::Context->dbh;
@ -236,8 +230,20 @@ sub ExportFramework
$subtable = 'auth_subfield_structure';
}
if (_export_table($table, $dbh, ($mode eq 'csv')?$xmlStrRef:$dom, ($mode eq 'ods')?$elementSS:$root, $frameworkcode, $mode, $frameworktype)) {
if (_export_table($subtable, $dbh, ($mode eq 'csv')?$xmlStrRef:$dom, ($mode eq 'ods')?$elementSS:$root, $frameworkcode, $mode, $frameworktype)) {
if (
_export_table(
$table, $dbh, ( $mode eq 'csv' ) ? $xmlStrRef : $dom, ( $mode eq 'ods' ) ? $elementSS : $root,
$frameworkcode, $mode, $frameworktype
)
)
{
if (
_export_table(
$subtable, $dbh, ( $mode eq 'csv' ) ? $xmlStrRef : $dom, ( $mode eq 'ods' ) ? $elementSS : $root,
$frameworkcode, $mode, $frameworktype
)
)
{
$$xmlStrRef = $dom->toString(1) if ( $mode eq 'ods' || $mode eq 'excel' );
return 1;
}
@ -246,12 +252,8 @@ sub ExportFramework
return 0;
} #ExportFramework
# Export all the data from a mysql table to an spreadsheet.
sub _export_table
{
sub _export_table {
my ( $table, $dbh, $dom, $root, $frameworkcode, $mode, $frameworktype ) = @_;
if ( $mode eq 'csv' ) {
_export_table_csv( $table, $dbh, $dom, $root, $frameworkcode, $frameworktype );
@ -263,8 +265,7 @@ sub _export_table
}
# Export the mysql table to an csv file
sub _export_table_csv
{
sub _export_table_csv {
my ( $table, $dbh, $strCSV, $root, $frameworkcode, $frameworktype ) = @_;
eval {
@ -279,6 +280,7 @@ sub _export_table_csv
}
chop $$strCSV;
$$strCSV .= chr(10);
# Populate rows with the data from mysql
$query = 'SELECT * FROM ' . $table . ' WHERE frameworkcode=?';
if ( $frameworktype eq "authority" ) {
@ -299,6 +301,7 @@ sub _export_table_csv
}
$$strCSV .= chr(10);
for (@fields) {
# Separator for change of table
$$strCSV .= '"#-#",';
}
@ -313,10 +316,8 @@ sub _export_table_csv
return 1;
} #_export_table_csv
# Export the mysql table to an ods file
sub _export_table_ods
{
sub _export_table_ods {
my ( $table, $dbh, $dom, $root, $frameworkcode, $frameworktype ) = @_;
eval {
@ -329,6 +330,7 @@ sub _export_table_ods
my $elementCell;
my $elementData;
# First row with the name of the columns
my $query = 'SHOW COLUMNS FROM ' . $table;
my $sth = $dbh->prepare($query);
@ -344,6 +346,7 @@ sub _export_table_ods
$elementData->appendTextNode( $hashRef->{Field} );
push @fields, { name => $hashRef->{Field}, type => ( $hashRef->{Type} =~ /int/i ) ? 'float' : 'string' };
}
# Populate rows with the data from mysql
$query = 'SELECT * FROM ' . $table . ' WHERE frameworkcode=?';
if ( $frameworktype eq "authority" ) {
@ -382,10 +385,8 @@ sub _export_table_ods
return 1;
} #_export_table_ods
# Export the mysql table to an excel-xml (openoffice/libreoffice compatible) file
sub _export_table_excel
{
sub _export_table_excel {
my ( $table, $dbh, $dom, $root, $frameworkcode, $frameworktype ) = @_;
eval {
@ -414,6 +415,7 @@ sub _export_table_excel
$elementData->appendTextNode( $hashRef->{Field} );
push @fields, { name => $hashRef->{Field}, type => ( $hashRef->{Type} =~ /int/i ) ? 'Number' : 'String' };
}
# Populate rows with the data from mysql
$query = 'SELECT * FROM ' . $table . ' WHERE frameworkcode=?';
if ( $frameworktype eq "authority" ) {
@ -451,8 +453,7 @@ sub _export_table_excel
} #_export_table_excel
# Format chars problematics to a correct format for xml.
sub _parseContent2Xml
{
sub _parseContent2Xml {
my $content = shift;
$content =~ s/\&(?![a-zA-Z#0-9]{1,4};)/&amp;/g;
@ -461,10 +462,8 @@ sub _parseContent2Xml
return $content;
} #_parseContent2Xml
# Get the tmp directory on the system
sub _getTmp
{
sub _getTmp {
my $tmp = '/tmp';
if ( $ENV{'TMP'} && -d $ENV{'TMP'} ) {
$tmp = $ENV{'TMP'};
@ -476,17 +475,13 @@ sub _getTmp
return $tmp;
} #_getTmp
# Create our tempdir directory for the ods process
sub _createTmpDir
{
sub _createTmpDir {
my $tmp = shift;
my $tempdir = ( -d $tmp ) ? $tmp . '/' : './';
$tempdir .= 'tmp_ods_' . Digest::MD5::md5_hex( Digest::MD5::md5_hex( time() . {} . rand() . {} . $$ ) );
eval {
mkdir $tempdir;
};
eval { mkdir $tempdir; };
if ($@) {
return;
} else {
@ -503,8 +498,7 @@ success
=cut
sub createODS
{
sub createODS {
my ( $strContent, $lang, $strODSRef ) = @_;
my $tmp = _getTmp();
@ -521,6 +515,7 @@ sub createODS
}
if ($tempdir) {
my $fh;
# populate tempdir directory with the ods elements
eval {
if ( open( $fh, '>', "$tempdir/content.xml" ) ) {
@ -562,6 +557,7 @@ sub createODS
if ($@) {
Koha::Logger->get->warn("Error createODS $@");
} else {
# create ods file from tempdir directory
eval {
require Archive::Zip;
@ -577,6 +573,7 @@ sub createODS
system("cd $tempdir && $cmd -r new.ods ./");
}
my $ok = 0;
# read ods file and return as a string
if ( -f "$tempdir/new.ods" ) {
if ( open( $fh, '<', "$tempdir/new.ods" ) ) {
@ -589,6 +586,7 @@ sub createODS
$ok = 1;
}
}
# delete tempdir directory
if ( !$tempModule && $tempdir ) {
eval {
@ -606,10 +604,8 @@ sub createODS
return 0;
} #createODS
# return Meta content for ods file
sub _getMeta
{
sub _getMeta {
my $lang = shift;
my $myDate = strftime( "%Y-%m-%dT%H:%M:%S", localtime( time() ) );
@ -631,7 +627,6 @@ sub _getMeta
return $meta;
} #_getMeta
=head2 ImportFramework
Import all the information of a MARC or Authority Type Framework from a excel-xml/ods file.
@ -641,8 +636,7 @@ success
=cut
sub ImportFramework
{
sub ImportFramework {
my ( $filename, $frameworkcode, $deleteFilename, $frameworktype ) = @_;
my $tempdir;
@ -664,6 +658,7 @@ sub ImportFramework
my $dom;
eval {
if ( $extension eq 'ods' || $extension eq 'xml' ) {
# They have xml structure, so read it on a dom object
my $parser = XML::LibXML->new();
$dom = $parser->parse_file($filename);
@ -671,6 +666,7 @@ sub ImportFramework
my $root = $dom->documentElement();
}
} else {
# They are text files, so open it to read
open( $dom, '<', $filename );
}
@ -683,21 +679,54 @@ sub ImportFramework
}
if ($dom) {
# Process both tables
my $numDeleted = 0;
my $numDeletedAux = 0;
if ( $frameworktype eq "authority" ) {
if (($numDeletedAux = _import_table($dbh, $table, $frameworkcode, $dom, ['authtypecode', 'tagfield'], $extension, $frameworktype)) >= 0) {
if (
(
$numDeletedAux = _import_table(
$dbh, $table, $frameworkcode, $dom, [ 'authtypecode', 'tagfield' ], $extension,
$frameworktype
)
) >= 0
)
{
$numDeleted += $numDeletedAux if ( $numDeletedAux > 0 );
if (($numDeletedAux = _import_table($dbh, $subtable, $frameworkcode, $dom, ['authtypecode', 'tagfield', 'tagsubfield'], $extension, $frameworktype)) >= 0) {
if (
(
$numDeletedAux = _import_table(
$dbh, $subtable, $frameworkcode, $dom,
[ 'authtypecode', 'tagfield', 'tagsubfield' ], $extension, $frameworktype
)
) >= 0
)
{
$numDeleted += $numDeletedAux if ( $numDeletedAux > 0 );
$ok = ( $numDeleted > 0 ) ? $numDeleted : 0;
}
}
} else {
if (($numDeletedAux = _import_table($dbh, $table, $frameworkcode, $dom, ['frameworkcode', 'tagfield'], $extension, $frameworktype)) >= 0) {
if (
(
$numDeletedAux = _import_table(
$dbh, $table, $frameworkcode, $dom, [ 'frameworkcode', 'tagfield' ], $extension,
$frameworktype
)
) >= 0
)
{
$numDeleted += $numDeletedAux if ( $numDeletedAux > 0 );
if (($numDeletedAux = _import_table($dbh, $subtable, $frameworkcode, $dom, ['frameworkcode', 'tagfield', 'tagsubfield'], $extension, $frameworktype)) >= 0) {
if (
(
$numDeletedAux = _import_table(
$dbh, $subtable, $frameworkcode, $dom,
[ 'frameworkcode', 'tagfield', 'tagsubfield' ], $extension, $frameworktype
)
) >= 0
)
{
$numDeleted += $numDeletedAux if ( $numDeletedAux > 0 );
$ok = ( $numDeleted > 0 ) ? $numDeleted : 0;
}
@ -733,8 +762,7 @@ sub ImportFramework
} #ImportFramework
# Open (uncompress) ods file and return the content.xml file
sub _openODS
{
sub _openODS {
my ( $filename, $deleteFilename ) = @_;
my $tmp = _getTmp();
@ -776,11 +804,8 @@ sub _openODS
return ( $tempdir, undef );
} #_openODS
# Check the table and columns corresponds with worksheet
sub _check_validity_worksheet
{
sub _check_validity_worksheet {
my ( $dbh, $table, $nodeFields, $fieldsA, $format ) = @_;
my $ret = 0;
@ -793,6 +818,7 @@ sub _check_validity_worksheet
$sth = $dbh->prepare($query);
$sth->execute();
my $fields = {};
while ( my $hashRef = $sth->fetchrow_hashref ) {
$fields->{ $hashRef->{Field} } = $hashRef->{Field};
}
@ -815,15 +841,14 @@ sub _check_validity_worksheet
return $ret;
} #_check_validity_worksheet
# Import the data from an excel-xml/ods to mysql tables.
sub _import_table
{
sub _import_table {
my ( $dbh, $table, $frameworkcode, $dom, $PKArray, $format, $frameworktype ) = @_;
my %fields2Delete;
my $query;
my @fields;
$frameworktype ||= '';
# Create hash with all elements defined by primary key to know which ones to delete after parsing the spreadsheet
eval {
@fields = @$PKArray;
@ -854,7 +879,10 @@ sub _import_table
push @fieldsName, $hashRef->{Field};
}
};
$ok = _import_table_csv($dbh, $table, $frameworkcode, $dom, $PKArray, \%fields2Delete, \@fieldsName, $frameworktype);
$ok = _import_table_csv(
$dbh, $table, $frameworkcode, $dom, $PKArray, \%fields2Delete, \@fieldsName,
$frameworktype
);
} elsif ( $format eq 'ods' ) {
$ok = _import_table_ods( $dbh, $table, $frameworkcode, $dom, $PKArray, \%fields2Delete, $frameworktype );
} else {
@ -867,9 +895,7 @@ sub _import_table
$query = substr( $query, 0, -4 );
my $sth = $dbh->prepare($query);
for ( keys %fields2Delete ) {
eval {
$sth->execute(($frameworkcode, split('_', $_)));
};
eval { $sth->execute( ( $frameworkcode, split( '_', $_ ) ) ); };
}
}
} else {
@ -878,15 +904,17 @@ sub _import_table
return $ok;
} #_import_table
# Insert/Update the row from the spreadsheet in the database
sub _processRow_DB
{
my ($dbh, $table, $fields, $dataStr, $updateStr, $dataFields, $dataFieldsHash, $PKArray, $fieldsPK, $fields2Delete) = @_;
sub _processRow_DB {
my (
$dbh, $table, $fields, $dataStr, $updateStr, $dataFields, $dataFieldsHash, $PKArray, $fieldsPK,
$fields2Delete
) = @_;
my $ok = 0;
my $query;
$query = 'INSERT INTO ' . $table . ' (' . $fields . ') VALUES (' . $dataStr . ') ON DUPLICATE KEY UPDATE ' . $updateStr;
$query =
'INSERT INTO ' . $table . ' (' . $fields . ') VALUES (' . $dataStr . ') ON DUPLICATE KEY UPDATE ' . $updateStr;
eval {
my $sth = $dbh->prepare($query);
$sth->execute( ( @$dataFields, @$dataFields ) );
@ -905,10 +933,8 @@ sub _processRow_DB
return $ok;
} #_processRow_DB
# Process the rows of a worksheet and insert/update them in a mysql table.
sub _processRows_Table
{
sub _processRows_Table {
my ( $dbh, $frameworkcode, $nodeR, $table, $PKArray, $format, $fields2Delete, $frameworktype ) = @_;
my $query;
@ -920,9 +946,17 @@ sub _processRows_Table
my $ok = 0;
my @fieldsPK = @$PKArray;
shift @fieldsPK;
while ($nodeR) {
if ($nodeR->nodeType == 1 && (($format && $format eq 'ods' && $nodeR->nodeName =~ /(?:table:)?table-row/) || ($nodeR->nodeName =~ /(?:ss:)?Row/)) && $nodeR->hasChildNodes()) {
if (
$nodeR->nodeType == 1
&& ( ( $format && $format eq 'ods' && $nodeR->nodeName =~ /(?:table:)?table-row/ )
|| ( $nodeR->nodeName =~ /(?:ss:)?Row/ ) )
&& $nodeR->hasChildNodes()
)
{
if ( $j == 0 ) {
# Get name columns
_getFields( $nodeR, \@fields, $format );
return 0 unless _check_validity_worksheet( $dbh, $table, $nodeR, \@fields, $format );
@ -934,12 +968,20 @@ sub _processRows_Table
map { $updateStr .= $_ . '=?,'; } @fields;
chop($updateStr) if ($updateStr);
} else {
# Get data from row
my ($dataFields, $dataFieldsR) = _getDataFields($frameworkcode, $nodeR, \@fields, $format, $frameworktype);
my ( $dataFields, $dataFieldsR ) =
_getDataFields( $frameworkcode, $nodeR, \@fields, $format, $frameworktype );
if ( scalar(@fields) == scalar(@$dataFieldsR) ) {
$ok = _processRow_DB($dbh, $table, $fields, $dataStr, $updateStr, $dataFieldsR, $dataFields, $PKArray, \@fieldsPK, $fields2Delete);
$ok = _processRow_DB(
$dbh, $table, $fields, $dataStr, $updateStr, $dataFieldsR, $dataFields,
$PKArray, \@fieldsPK, $fields2Delete
);
} else {
warn "$j don't match number of fields " . scalar(@fields) . ' vs ' . scalar(@$dataFieldsR) . "($dataStr)";
warn "$j don't match number of fields "
. scalar(@fields) . ' vs '
. scalar(@$dataFieldsR)
. "($dataStr)";
}
}
$j++;
@ -949,12 +991,8 @@ sub _processRows_Table
return 1;
} #_processRows_Table
# Import worksheet from the csv file to the mysql table
sub _import_table_csv
{
sub _import_table_csv {
my ( $dbh, $table, $frameworkcode, $dom, $PKArray, $fields2Delete, $fields, $frameworktype ) = @_;
my $row = '';
my $partialRow = '';
@ -967,6 +1005,7 @@ sub _import_table_csv
my $ok = 0;
my $pos = 0;
my $csv = Text::CSV_XS->new( { binary => 1, formula => "empty" } );
while ( my $row = $csv->getline($dom) ) {
my @fields = @$row;
@arrData = @fields;
@ -976,14 +1015,17 @@ sub _import_table_csv
#chop $arrData[$#arrData] if ($arrData[$#arrData] =~ /"$/);
if (@arrData) {
if ( $arrData[0] eq '#-#' && $arrData[$#arrData] eq '#-#' ) {
# Change of table with separators #-#
return 1;
} elsif ( $fieldsNameRead && $arrData[0] eq 'tagfield' ) {
# Change of table because we begin with field name with former field names read
seek( $dom, $pos, 0 );
return 1;
}
if ( !$fieldsNameRead ) {
# New table, we read the field names
$fieldsNameRead = 1;
$fields = [@arrData];
@ -997,12 +1039,14 @@ sub _import_table_csv
map { $updateStr .= $_ . '=?,'; } @$non_empty_fields;
chop($updateStr) if ($updateStr);
} else {
# Read data
my $j = 0;
my %dataFields = ();
my @values;
for my $value (@arrData) {
if ( grep { $_ == $j } @empty_indexes ) {
# empty field
} elsif ( $frameworktype eq "authority" ) {
if ( $fields->[$j] eq 'authtypecode' && $value ne $frameworkcode ) {
@ -1015,7 +1059,7 @@ sub _import_table_csv
$dataFields{ $fields->[$j] } = $value;
push @values, $value;
}
$j++
$j++;
} else {
if ( $fields->[$j] eq 'frameworkcode' && $value ne $frameworkcode ) {
$dataFields{ $fields->[$j] } = $frameworkcode;
@ -1027,10 +1071,13 @@ sub _import_table_csv
$dataFields{ $fields->[$j] } = $value;
push @values, $value;
}
$j++
$j++;
}
}
$ok = _processRow_DB($dbh, $table, $fieldsStr, $dataStr, $updateStr, \@values, \%dataFields, $PKArray, \@fieldsPK, $fields2Delete);
$ok = _processRow_DB(
$dbh, $table, $fieldsStr, $dataStr, $updateStr, \@values, \%dataFields, $PKArray,
\@fieldsPK, $fields2Delete
);
}
$pos = tell($dom);
}
@ -1039,10 +1086,8 @@ sub _import_table_csv
return $ok;
} #_import_table_csv
# Import worksheet from the ods content.xml file to the mysql table
sub _import_table_ods
{
sub _import_table_ods {
my ( $dbh, $table, $frameworkcode, $dom, $PKArray, $fields2Delete, $frameworktype ) = @_;
my $xc = XML::LibXML::XPathContext->new($dom);
@ -1053,17 +1098,18 @@ sub _import_table_ods
@nodes = $xc->findnodes( '//table:table[@table:name="' . $table . '"]' );
if ( @nodes == 1 && $nodes[0]->hasChildNodes() ) {
my $nodeR = $nodes[0]->firstChild;
return _processRows_Table($dbh, $frameworkcode, $nodeR, $table, $PKArray, 'ods', $fields2Delete, $frameworktype);
return _processRows_Table(
$dbh, $frameworkcode, $nodeR, $table, $PKArray, 'ods', $fields2Delete,
$frameworktype
);
} else {
Koha::Logger->get->warn("Error _import_table_ods there's not worksheet for $table");
}
return 0;
} #_import_table_ods
# Import worksheet from the excel-xml file to the mysql table
sub _import_table_excel
{
sub _import_table_excel {
my ( $dbh, $table, $frameworkcode, $dom, $PKArray, $fields2Delete, $frameworktype ) = @_;
my $xc = XML::LibXML::XPathContext->new($dom);
@ -1077,7 +1123,10 @@ sub _import_table_excel
my @nodesT = $nodes[$i]->getElementsByTagNameNS( 'urn:schemas-microsoft-com:office:spreadsheet', 'Table' );
if ( @nodesT == 1 && $nodesT[0]->hasChildNodes() ) {
my $nodeR = $nodesT[0]->firstChild;
return _processRows_Table($dbh, $frameworkcode, $nodeR, $table, $PKArray, undef, $fields2Delete, $frameworktype);
return _processRows_Table(
$dbh, $frameworkcode, $nodeR, $table, $PKArray, undef, $fields2Delete,
$frameworktype
);
}
}
} else {
@ -1086,10 +1135,8 @@ sub _import_table_excel
return 0;
} #_import_table_excel
# Get the data from a cell on a ods file through the value attribute or the text node
sub _getDataNodeODS
{
sub _getDataNodeODS {
my $node = shift;
my $data;
@ -1104,16 +1151,15 @@ sub _getDataNodeODS
}
}
if ( $node->hasAttributeNS( 'urn:oasis:names:tc:opendocument:xmlns:table:1.0', 'number-columns-repeated' ) ) {
$repeated = $node->getAttributeNS('urn:oasis:names:tc:opendocument:xmlns:table:1.0', 'number-columns-repeated');
$repeated =
$node->getAttributeNS( 'urn:oasis:names:tc:opendocument:xmlns:table:1.0', 'number-columns-repeated' );
}
}
return ( $data, $repeated );
} #_getDataNodeODS
# Get the data from a row of a spreadsheet
sub _getDataFields
{
sub _getDataFields {
my ( $frameworkcode, $node, $fields, $format, $frameworktype ) = @_;
my $dataFields = {};
@ -1132,7 +1178,8 @@ sub _getDataFields
$ok = 1;
} else {
if ( $node2->nodeType == 1 && $node2->nodeName =~ /(?:ss:)?Cell/ ) {
my @nodes3 = $node2->getElementsByTagNameNS('urn:schemas-microsoft-com:office:spreadsheet', 'Data');
my @nodes3 =
$node2->getElementsByTagNameNS( 'urn:schemas-microsoft-com:office:spreadsheet', 'Data' );
if ( @nodes3 == 1 && $nodes3[0]->hasChildNodes() ) {
$data = $nodes3[0]->firstChild->nodeValue;
$ok = 1;
@ -1145,15 +1192,13 @@ sub _getDataFields
if ( $frameworktype eq "authority" ) {
if ( $fields->[$i] eq 'authtypecode' ) {
$data = $frameworkcode;
}
elsif ( $fields->[$i] eq 'isurl' ) {
} elsif ( $fields->[$i] eq 'isurl' ) {
$data = undef if defined $data && $data eq q{};
}
} else {
if ( $fields->[$i] eq 'frameworkcode' ) {
$data = $frameworkcode;
}
elsif ( $fields->[$i] eq 'isurl' ) {
} elsif ( $fields->[$i] eq 'isurl' ) {
$data = undef if defined $data && $data eq q{};
}
}
@ -1168,10 +1213,8 @@ sub _getDataFields
return ( $dataFields, \@dataFieldsA );
} #_getDataFields
# Get the data from the first row to know the column names
sub _getFields
{
sub _getFields {
my ( $node, $fields, $format ) = @_;
if ( $node && $node->hasChildNodes() ) {
@ -1183,7 +1226,8 @@ sub _getFields
push @$fields, $data if ( defined($data) );
} else {
if ( $node2->nodeType == 1 && $node2->nodeName =~ /(?:ss:)?Cell/ ) {
my @nodes3 = $node2->getElementsByTagNameNS('urn:schemas-microsoft-com:office:spreadsheet', 'Data');
my @nodes3 =
$node2->getElementsByTagNameNS( 'urn:schemas-microsoft-com:office:spreadsheet', 'Data' );
if ( @nodes3 == 1 && $nodes3[0]->hasChildNodes() ) {
$data = $nodes3[0]->firstChild->nodeValue;
push @$fields, $data;
@ -1195,9 +1239,6 @@ sub _getFields
}
} #_getFields
1;
__END__

20
C4/InstallAuth.pm
View File

@ -30,6 +30,7 @@ use C4::Templates;
use Koha::Session;
our ( @ISA, @EXPORT_OK );
BEGIN {
@ISA = qw(Exporter);
@EXPORT_OK = qw(
@ -115,7 +116,7 @@ sub get_template_and_user {
my $request_method = $in->{query}->request_method // q{};
unless ( $request_method eq 'POST' && $in->{query}->param('op') eq 'cud-login' ) {
$in->{query}->param( 'login_userid', '' );
$in->{query}->param('login_password', '')
$in->{query}->param( 'login_password', '' );
}
my ( $user, $cookie, $sessionID, $flags ) = checkauth(
@ -277,6 +278,7 @@ sub checkauth {
}
if ( $logout || !$session ) {
# voluntary logout the user
C4::Context->unset_userenv();
$session = Koha::Session->get_session( { storage_method => 'file' } );
@ -290,6 +292,7 @@ sub checkauth {
my ( $return, $cardnumber ) = checkpw( $userid, $password );
if ($return) {
$loggedin = 1;
# open L, ">>/tmp/sessionlog";
# my $time = localtime( time() );
# printf L "%20s from %16s logged in at %30s.\n", $userid,
@ -322,14 +325,15 @@ sub checkauth {
$session->param( 'branch', 'NO_LIBRARY_SET' );
$session->param( 'branchname', 'NO_LIBRARY_SET' );
$session->param( 'flags', 1 );
$session->param( 'emailaddress',
C4::Context->preference('KohaAdminEmailAddress') );
$session->param(
'emailaddress',
C4::Context->preference('KohaAdminEmailAddress')
);
$session->param( 'ip', $session->remote_addr() );
$session->param( 'lasttime', time() );
$userid = C4::Context->config('user');
}
}
else {
} else {
if ($userid) {
$info{'invalid_username_or_password'} = 1;
C4::Context->unset_userenv();
@ -353,8 +357,7 @@ sub checkauth {
}
if ($envcookie) {
return ( $userid, [ $cookie, $envcookie ], $sessionID, $flags );
}
else {
} else {
return ( $userid, $cookie, $sessionID, $flags );
}
}
@ -369,7 +372,8 @@ sub checkauth {
}
my $path =
C4::Context->config('intrahtdocs') . "/prog/"
C4::Context->config('intrahtdocs')
. "/prog/"
. ( $query->param('language') ? $query->param('language') : "en" );
my $filename = "$path/modules/$template_name";
my $interface = 'intranet';

127
C4/Installer.pm
View File

@ -33,11 +33,13 @@ use Koha::Installer;
use Koha::Installer::Output qw ( say_failure );
use vars qw(@ISA @EXPORT);
BEGIN {
require Exporter;
@ISA = qw( Exporter );
push @EXPORT, qw( primary_key_exists unique_key_exists foreign_key_exists index_exists column_exists TableExists marc_framework_sql_list TransformToNum CheckVersion NewVersion SetVersion sanitize_zero_date update get_db_entries get_atomic_updates run_atomic_updates has_non_dynamic_row_format );
};
push @EXPORT,
qw( primary_key_exists unique_key_exists foreign_key_exists index_exists column_exists TableExists marc_framework_sql_list TransformToNum CheckVersion NewVersion SetVersion sanitize_zero_date update get_db_entries get_atomic_updates run_atomic_updates has_non_dynamic_row_format );
}
=head1 NAME
@ -82,17 +84,27 @@ sub new {
$self->{'user'} = C4::Context->config("user");
$self->{'password'} = C4::Context->config("pass");
$self->{'tls'} = C4::Context->config("tls");
if ( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
$self->{'ca'} = C4::Context->config('ca');
$self->{'cert'} = C4::Context->config('cert');
$self->{'key'} = C4::Context->config('key');
$self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
$self->{'tlscmdline'} = " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
$self->{'tlsoptions'} =
";mysql_ssl=1;mysql_ssl_client_key="
. $self->{key}
. ";mysql_ssl_client_cert="
. $self->{cert}
. ";mysql_ssl_ca_file="
. $self->{ca};
$self->{'tlscmdline'} =
" --ssl-cert " . $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca " . $self->{ca} . " ";
}
$self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
( $self->{port} ? ";port=$self->{port}" : "" ).
( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
$self->{'user'}, $self->{'password'});
$self->{'dbh'} = DBI->connect(
"DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}"
. ( $self->{port} ? ";port=$self->{port}" : "" )
. ( $self->{tlsoptions} ? $self->{tlsoptions} : "" ),
$self->{'user'}, $self->{'password'}
);
$self->{'language'} = undef;
$self->{'marcflavour'} = undef;
$self->{'dbh'}->do('set NAMES "utf8"');
@ -124,15 +136,18 @@ sub marc_framework_sql_list {
my $defaulted_to_en = 0;
undef $/;
my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
my $dir =
C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/" . lc($marcflavour);
my $dir_h;
unless ( opendir( $dir_h, $dir ) ) {
if ( $lang eq 'en' ) {
warn "cannot open MARC frameworks directory $dir";
} else {
# if no translated MARC framework is available,
# default to English
$dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
$dir =
C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/" . lc($marcflavour);
opendir( $dir_h, $dir ) or warn "cannot open English MARC frameworks directory $dir";
$defaulted_to_en = 1;
}
@ -215,6 +230,7 @@ sub sample_data_sql_list {
if ( $lang eq 'en' ) {
warn "cannot open sample data directory $dir";
} else {
# if no sample data is available,
# default to English
$dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
@ -358,7 +374,8 @@ sub load_sql_in_order {
my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
# Make sure some stuffs are loaded first
unshift(@fnames,
unshift(
@fnames,
"$global_mandatory_dir/sysprefs.sql",
"$global_mandatory_dir/subtag_registry.sql",
"$global_mandatory_dir/auth_val_cat.sql",
@ -372,12 +389,13 @@ sub load_sql_in_order {
"$global_mandatory_dir/userpermissions.sql",
"$global_mandatory_dir/audio_alerts.sql",
;
my $localization_file = C4::Context->config('intranetdir') .
"/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
my $localization_file =
C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
if ( -f $localization_file ) {
push @fnames, $localization_file;
}
foreach my $file (@fnames) {
# warn $file;
undef $/;
my $error = $self->load_sql($file);
@ -408,9 +426,8 @@ sub load_sql_in_order {
}
}
my $updateflag =
$self->{'dbh'}->do(
"UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
);
$self->{'dbh'}
->do("UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'");
unless ( $updateflag == 1 ) {
my $string =
@ -463,6 +480,7 @@ sub set_version_syspref {
my $self = shift;
my $kohaversion = Koha::version();
# remove the 3 last . to have a Perl number
$kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
if ( C4::Context->preference('Version') ) {
@ -471,7 +489,10 @@ sub set_version_syspref {
$finish->execute($kohaversion);
} else {
warn "INSERT Version";
my $finish=$self->{'dbh'}->prepare("INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')");
my $finish =
$self->{'dbh'}->prepare(
"INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')"
);
$finish->execute($kohaversion);
}
C4::Context->clear_syspref_cache();
@ -493,9 +514,11 @@ sub set_languages_syspref {
return if ( not $language or $language eq 'en' );
warn "UPDATE Languages";
# intranet
my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='StaffInterfaceLanguages'");
$pref->execute("en,$language");
# opac
$pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
$pref->execute("en,$language");
@ -522,13 +545,16 @@ sub process_yml_table {
my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
my $placeholders = '(' . join( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
my @values;
foreach my $row (@rows) {
push @values, [ map {
push @values, [
map {
my $col = $_;
( @multiline and grep { $_ eq $col } @multiline )
? join "\r\n", @{ $row->{$col} } # join multiline values
: $row->{$col};
} @columns ];
} @columns
];
}
return { query => $query, placeholders => $placeholders, values => \@values };
}
@ -564,8 +590,7 @@ sub load_sql {
sql => $filename,
);
};
}
else { # YAML files
} else { # YAML files
eval {
my $yaml = YAML::XS::LoadFile($filename); # Load YAML
for my $table ( @{ $yaml->{'tables'} } ) {
@ -573,6 +598,7 @@ sub load_sql {
my $query = $query_info->{query};
my $placeholders = $query_info->{placeholders};
my $values = $query_info->{values};
# Doing only 1 INSERT query for the whole table
my @all_rows_values = map { @$_ } @$values;
$query .= join ', ', ($placeholders) x scalar @$values;
@ -587,6 +613,7 @@ sub load_sql {
warn "Something went wrong loading file $filename ($@)";
}
};
# errors thrown while loading installer data should be logged
if ($dup_stderr) {
warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
@ -615,6 +642,7 @@ sub get_file_path_from_name {
my $lang = 'en'; # FIXME: how do I know what language I want?
my ( $defaulted_to_en, $list ) = $self->sample_data_sql_list($lang);
# warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
my @found;
@ -716,7 +744,7 @@ sub get_db_entries {
unless ($version) {
warn "Invalid db_rev found: " . $file;
next
next;
}
next unless CheckVersion($version);
@ -741,8 +769,7 @@ sub run_db_rev {
$db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
}
);
}
catch {
} catch {
$error = $_;
say_failure( $outfh, "ERROR: " . $error );
};
@ -776,6 +803,7 @@ sub update {
if ( $db_entry->{error} ) {
push @errors, $db_entry;
$force ? next : last;
# We stop the update if an error occurred!
}
@ -794,7 +822,8 @@ sub generate_output_db_entry {
my $bug_number = $db_entry->{bug_number};
my $time = $db_entry->{time};
my $exec_output = $db_entry->{exec_output};
my $done = defined $db_entry->{done}
my $done =
defined $db_entry->{done}
? $db_entry->{done}
? " done"
: " failed"
@ -804,13 +833,18 @@ sub generate_output_db_entry {
if ($DBversion) {
if ($bug_number) {
push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
push @output,
sprintf( 'Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description );
} else {
push @output, sprintf( 'Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description );
}
} else { # Atomic update
if ($bug_number) {
push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
push @output,
sprintf(
'DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time,
$bug_number, $description
);
} else { # Old atomic update syntax
push @output, sprintf( 'DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time );
}
@ -862,7 +896,6 @@ sub run_atomic_updates {
time => POSIX::strftime( "%H:%M:%S", localtime ),
};
$atomic_update->{output} =
$out
? [ split "\n", $out ]
@ -893,19 +926,24 @@ Drop all foreign keys of the table $table
sub DropAllForeignKeys {
my ($table) = @_;
# get the table description
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
$sth->execute;
my $vsc_structure = $sth->fetchrow;
# split on CONSTRAINT keyword
my @fks = split /CONSTRAINT /, $vsc_structure;
# parse each entry
foreach (@fks) {
# isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
$_ = /(.*) FOREIGN KEY.*/;
my $id = $1;
if ($id) {
# we have found 1 foreign, drop it
$dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
$id = "";
@ -913,7 +951,6 @@ sub DropAllForeignKeys {
}
}
=head2 TransformToNum
Transform the Koha version from a 4 parts string
@ -935,6 +972,7 @@ set the DBversion in the systempreferences
sub SetVersion {
return if $_[0] =~ /XXX$/;
#you are testing a patch with a db revision; do not change version
my $kohaversion = TransformToNum( $_[0] );
my $dbh = C4::Context->dbh;
@ -942,7 +980,9 @@ sub SetVersion {
my $finish = $dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
$finish->execute($kohaversion);
} else {
my $finish=$dbh->prepare("INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')");
my $finish = $dbh->prepare(
"INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')"
);
$finish->execute($kohaversion);
}
C4::Context::clear_syspref_cache(); # invalidate cached preferences
@ -959,18 +999,19 @@ sub NewVersion {
if ( ref($descriptions) ) {
$description = shift @$descriptions;
$report = join( "\n", @{$descriptions} );
}
else {
} else {
$description = $descriptions;
}
my $output = generate_output_db_entry( {
my $output = generate_output_db_entry(
{
bug_number => $bug_number,
description => $description,
report => $report,
version => $DBversion,
time => POSIX::strftime( "%H:%M:%S", localtime ),
});
}
);
say join "\n", @$output;
@ -1008,21 +1049,27 @@ sub sanitize_zero_date {
my $dbh = C4::Context->dbh;
my (undef, $datatype) = $dbh->selectrow_array(qq|
SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
my ( undef, $datatype ) = $dbh->selectrow_array(
qq|
SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name
);
if ( $datatype eq 'date' ) {
$dbh->do(qq|
$dbh->do(
qq|
UPDATE $table_name
SET $column_name = NULL
WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
|);
|
);
} else {
$dbh->do(qq|
$dbh->do(
qq|
UPDATE $table_name
SET $column_name = NULL
WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
|);
|
);
}
}

7
C4/Installer/UpgradeBackup.pm
View File

@ -57,7 +57,8 @@ sub backup_changed_files {
chdir $currdir or die "could not change to $currdir: $!";
# expand path
find(sub {
find(
sub {
return unless -f $_;
my $filename = $_;
@ -74,7 +75,9 @@ sub backup_changed_files {
File::Copy::copy( $targetfile, $backup );
}
}
}, ".");
},
"."
);
}
}

32
C4/ItemCirculationAlertPreference.pm
View File

@ -35,9 +35,6 @@ our $valid = sub {
}
};
=head1 NAME
C4::ItemCirculationAlertPreference - manage preferences for sending alerts
@ -97,9 +94,6 @@ sub new {
bless $opts => $class;
}
=head3 C4::ItemCirculationAlertPreference->create(\%opts)
This will find or create an item circulation alert preference. You must pass
@ -173,9 +167,6 @@ sub create {
}
}
=head3 C4::ItemCirculationAlertPreference->delete(\%opts)
Delete an item circulation alert preference. You can delete by either passing
@ -195,8 +186,7 @@ sub delete {
);
} else {
$valid->($opts);
my $sql =
"DELETE FROM item_circulation_alert_preferences
my $sql = "DELETE FROM item_circulation_alert_preferences
WHERE branchcode = ?
AND categorycode = ?
AND item_type = ?
@ -212,9 +202,6 @@ sub delete {
}
}
=head3 C4::ItemCirculationAlertPreference->is_enabled_for(\%opts)
Based on the existing preferences in the C<item_circulation_alert_preferences>
@ -269,9 +256,6 @@ sub is_enabled_for {
return not $class->is_disabled_for($opts);
}
=head3 C4::ItemCirculationAlertPreference->find({ branchcode => $bc, notification => $type })
This method returns all the item circulation alert preferences for a given
@ -295,17 +279,16 @@ sub find {
WHERE branchcode = ? AND notification = ?
ORDER BY categorycode, item_type
};
return map { $class->new($_) } @{$dbh->selectall_arrayref(
return map { $class->new($_) } @{
$dbh->selectall_arrayref(
$query,
{ Slice => {} },
$where->{branchcode},
$where->{notification},
)};
)
};
}
=head3 C4::ItemCirculationAlertPreference->grid({ branchcode => $c, notification => $type })
Return a 2D arrayref for the grid view in F<admin/item_circulation_alert_preferences.pl>.
@ -371,9 +354,6 @@ sub grid {
return \@grid;
}
=head2 Object Methods
These are read-only accessors for the various attributes of a preference.
@ -411,8 +391,6 @@ sub AUTOLOAD {
sub DESTROY { }
=head1 SEE ALSO
L<C4::Circulation>, F<admin/item_circulation_alerts.pl>

200
C4/Items.pm
View File

@ -21,6 +21,7 @@ package C4::Items;
use Modern::Perl;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -54,6 +55,7 @@ use C4::ClassSource qw( GetClassSort GetClassSources GetClassSource );
use C4::Log qw( logaction );
use List::MoreUtils qw( any );
use DateTime::Format::MySQL;
# debugging; so please don't remove this
use Try::Tiny qw( catch try );
@ -232,12 +234,14 @@ sub AddItemBatchFromMarc {
# We modify the record, so lets work on a clone so we don't change the
# original.
$record = $record->clone();
# loop through the item tags and start creating items
my @bad_item_fields = ();
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField("items.itemnumber");
my $item_sequence_num = 0;
ITEMFIELD: foreach my $item_field ( $record->field($itemtag) ) {
$item_sequence_num++;
# we take the item field and stick it into a new
# MARC record -- this is required so far because (FIXME)
# TransformMarcToKoha requires a MARC::Record, not a MARC::Field
@ -265,7 +269,8 @@ sub AddItemBatchFromMarc {
my $item_object = Koha::Item->new($item)->store;
push @itemnumbers, $item_object->itemnumber; # FIXME not checking error
logaction("CATALOGUING", "ADD", $item_object->itemnumber, "item") if C4::Context->preference("CataloguingLog");
logaction( "CATALOGUING", "ADD", $item_object->itemnumber, "item" )
if C4::Context->preference("CataloguingLog");
my $new_item_marc = _marc_from_item_hash( $item_object->unblessed, $frameworkcode, $unlinked_item_subfields );
$item_field->replace_with( $new_item_marc->field($itemtag) );
@ -315,7 +320,8 @@ sub ModItemFromMarc {
if ( $item_object->dateaccessioned && !defined $item->{dateaccessioned} );
my ( $perm_loc_tag, $perm_loc_subfield ) = C4::Biblio::GetMarcFromKohaField("items.permanent_location");
my $has_permanent_location = defined $perm_loc_tag && defined $item_marc->subfield( $perm_loc_tag, $perm_loc_subfield );
my $has_permanent_location =
defined $perm_loc_tag && defined $item_marc->subfield( $perm_loc_tag, $perm_loc_subfield );
# Retrieving the values for the fields that are not linked
my @mapped_fields = Koha::MarcSubfieldStructures->search(
@ -443,7 +449,12 @@ sub ModDateLastSeen {
$item->datelastseen(dt_from_string);
my $log = $item->itemlost && !$leave_item_lost ? 1 : 0; # If item was lost, record the change to the item
$item->itemlost(0) unless $leave_item_lost;
$item->store({ log_action => $log, skip_record_index => $params->{skip_record_index}, skip_holds_queue => $params->{skip_holds_queue} });
$item->store(
{
log_action => $log, skip_record_index => $params->{skip_record_index},
skip_holds_queue => $params->{skip_holds_queue}
}
);
}
=head2 CheckItemPreSave
@ -660,7 +671,8 @@ sub GetItemsForInventory {
if (@$itemtypes) {
my $itemtypes_str = join ', ', @$itemtypes;
push @where_strings, "( biblioitems.itemtype IN (" . $itemtypes_str . ") OR items.itype IN (" . $itemtypes_str . ") )";
push @where_strings,
"( biblioitems.itemtype IN (" . $itemtypes_str . ") OR items.itype IN (" . $itemtypes_str . ") )";
}
if (@where_strings) {
@ -681,27 +693,34 @@ sub GetItemsForInventory {
my ($iTotalRecords) = $sth->fetchrow_array();
my @avs = Koha::AuthorisedValues->search(
{ 'marc_subfield_structures.kohafield' => { '>' => '' },
{
'marc_subfield_structures.kohafield' => { '>' => '' },
'me.authorised_value' => { '>' => '' },
},
{ join => { category => 'marc_subfield_structures' },
{
join => { category => 'marc_subfield_structures' },
distinct => ['marc_subfield_structures.kohafield, me.category, frameworkcode, me.authorised_value'],
'+select' => [ 'marc_subfield_structures.kohafield', 'marc_subfield_structures.frameworkcode', 'me.authorised_value', 'me.lib' ],
'+select' => [
'marc_subfield_structures.kohafield', 'marc_subfield_structures.frameworkcode', 'me.authorised_value',
'me.lib'
],
'+as' => [ 'kohafield', 'frameworkcode', 'authorised_value', 'lib' ],
}
)->as_list;
my $avmapping = { map { $_->get_column('kohafield') . ',' . $_->get_column('frameworkcode') . ',' . $_->get_column('authorised_value') => $_->get_column('lib') } @avs };
my $avmapping = {
map {
$_->get_column('kohafield') . ','
. $_->get_column('frameworkcode') . ','
. $_->get_column('authorised_value') => $_->get_column('lib')
} @avs
};
foreach my $row (@$tmpresults) {
# Auth values
foreach ( keys %$row ) {
if (
defined(
$avmapping->{ "items.$_," . $row->{'frameworkcode'} . "," . ( $row->{$_} // q{} ) }
)
) {
if ( defined( $avmapping->{ "items.$_," . $row->{'frameworkcode'} . "," . ( $row->{$_} // q{} ) } ) ) {
$row->{$_} = $avmapping->{ "items.$_," . $row->{'frameworkcode'} . "," . $row->{$_} };
}
}
@ -722,7 +741,6 @@ references on array of itemnumbers.
=cut
sub get_hostitemnumbers_of {
my ($biblionumber) = @_;
@ -741,8 +759,7 @@ sub get_hostitemnumbers_of {
$tag = '773';
$biblio_s = '0';
$item_s = '9';
}
elsif ( $marcflavor eq 'UNIMARC' ) {
} elsif ( $marcflavor eq 'UNIMARC' ) {
$tag = '461';
$biblio_s = '0';
$item_s = '9';
@ -756,7 +773,8 @@ sub get_hostitemnumbers_of {
warn "ERROR biblionumber $biblionumber has 773^0, but doesn't have 9";
next;
}
my $is_from_biblio = Koha::Items->search({ itemnumber => $linkeditemnumber, biblionumber => $hostbiblionumber });
my $is_from_biblio =
Koha::Items->search( { itemnumber => $linkeditemnumber, biblionumber => $hostbiblionumber } );
push @returnhostitemnumbers, $linkeditemnumber
if $is_from_biblio;
}
@ -808,12 +826,12 @@ sub GetMarcItem {
return Item2Marc( $item->unblessed, $biblionumber );
}
sub Item2Marc {
my ( $itemrecord, $biblionumber ) = @_;
my $mungeditem = {
map {
defined($itemrecord->{$_}) && $itemrecord->{$_} ne '' ? ("items.$_" => $itemrecord->{$_}) : ()
} keys %{ $itemrecord }
map { defined( $itemrecord->{$_} ) && $itemrecord->{$_} ne '' ? ( "items.$_" => $itemrecord->{$_} ) : () }
keys %{$itemrecord}
};
my $framework = C4::Biblio::GetFrameworkCode($biblionumber);
my $itemmarc = C4::Biblio::TransformKohaToMarc( $mungeditem, { framework => $framework } );
@ -861,9 +879,13 @@ sub _marc_from_item_hash {
# Tack on 'items.' prefix to column names so lookup from MARC frameworks will work
# Also, don't emit a subfield if the underlying field is blank.
my $mungeditem = { map { (defined($item->{$_}) and $item->{$_} ne '') ?
(/^items\./ ? ($_ => $item->{$_}) : ("items.$_" => $item->{$_}))
: () } keys %{ $item } };
my $mungeditem = {
map {
( defined( $item->{$_} ) and $item->{$_} ne '' )
? ( /^items\./ ? ( $_ => $item->{$_} ) : ( "items.$_" => $item->{$_} ) )
: ()
} keys %{$item}
};
my $item_marc = MARC::Record->new();
foreach my $item_field ( keys %{$mungeditem} ) {
@ -875,7 +897,10 @@ sub _marc_from_item_hash {
$field->add_subfields( $subfield => $value );
} else {
my $add_subfields = [];
if (defined $unlinked_item_subfields and ref($unlinked_item_subfields) eq 'ARRAY' and $#$unlinked_item_subfields > -1) {
if ( defined $unlinked_item_subfields
and ref($unlinked_item_subfields) eq 'ARRAY'
and $#$unlinked_item_subfields > -1 )
{
$add_subfields = $unlinked_item_subfields;
}
$item_marc->add_fields( $tag, " ", " ", $subfield => $value, @$add_subfields );
@ -932,9 +957,10 @@ sub _get_unlinked_item_subfields {
my $field = $fields[0];
my $tag = $field->tag();
foreach my $subfield ( $field->subfields() ) {
if (defined $subfield->[1] and
$subfield->[1] ne '' and
!$marcstructure->{$tag}->{$subfield->[0]}->{'kohafield'}) {
if ( defined $subfield->[1]
and $subfield->[1] ne ''
and !$marcstructure->{$tag}->{ $subfield->[0] }->{'kohafield'} )
{
push @$subfields, $subfield->[0] => $subfield->[1];
}
}
@ -952,8 +978,12 @@ sub _get_unlinked_subfields_xml {
my $unlinked_item_subfields = shift;
my $xml;
if (defined $unlinked_item_subfields and ref($unlinked_item_subfields) eq 'ARRAY' and $#$unlinked_item_subfields > -1) {
if ( defined $unlinked_item_subfields
and ref($unlinked_item_subfields) eq 'ARRAY'
and $#$unlinked_item_subfields > -1 )
{
my $marc = MARC::Record->new();
# use of tag 999 is arbitrary, and doesn't need to match the item tag
# used in the framework
$marc->append_fields( MARC::Field->new( '999', ' ', ' ', @$unlinked_item_subfields ) );
@ -1052,14 +1082,17 @@ sub _SearchItems_build_where_fragment {
if ( $field =~ /^marc:(\d{3})(?:\$(\w))?$/ ) {
my $marcfield = $1;
my $marcsubfield = $2;
my ($kohafield) = $dbh->selectrow_array(q|
my ($kohafield) = $dbh->selectrow_array(
q|
SELECT kohafield FROM marc_subfield_structure
WHERE tagfield=? AND tagsubfield=? AND frameworkcode=''
|, undef, $marcfield, $marcsubfield);
|, undef, $marcfield, $marcsubfield
);
if ($kohafield) {
$column = $kohafield;
} else {
# MARC field is not linked to a DB field so we need to use
# ExtractValue on marcxml from biblio_metadata or
# items.more_subfields_xml, depending on the MARC field.
@ -1079,16 +1112,14 @@ sub _SearchItems_build_where_fragment {
}
$column = "ExtractValue($sqlfield, '$xpath')";
}
}
elsif ($field eq 'isbn') {
} elsif ( $field eq 'isbn' ) {
if ( C4::Context->preference("SearchWithISBNVariations") and $query ) {
my @isbns = C4::Koha::GetVariationsOfISBN($query);
$query = [];
push @$query, @isbns;
}
$column = $field;
}
elsif ($field eq 'issn') {
} elsif ( $field eq 'issn' ) {
if ( C4::Context->preference("SearchWithISSNVariations") and $query ) {
my @issns = C4::Koha::GetVariationsOfISSN($query);
$query = [];
@ -1109,8 +1140,7 @@ sub _SearchItems_build_where_fragment {
str => "($column LIKE " . join( " OR $column LIKE ", ('?') x @$query ) . ")",
args => $query,
};
}
else {
} else {
if ( $op eq '=' ) {
$op = 'IN';
} elsif ( $op eq '!=' ) {
@ -1236,8 +1266,7 @@ sub SearchItems {
my $sortorder = ( uc( $params->{sortorder} ) eq 'ASC' ) ? 'ASC' : 'DESC';
$query .= qq{ ORDER BY onloan $sortorder };
} else {
my $sortby = (0 < grep {$params->{sortby} eq $_} @columns)
? $params->{sortby} : 'itemnumber';
my $sortby = ( 0 < grep { $params->{sortby} eq $_ } @columns ) ? $params->{sortby} : 'itemnumber';
$sortby = 'cn_sort' if $sortby eq 'itemcallnumber';
my $sortorder = ( uc( $params->{sortorder} ) eq 'ASC' ) ? 'ASC' : 'DESC';
$query .= qq{ ORDER BY $sortby $sortorder };
@ -1260,7 +1289,6 @@ sub SearchItems {
return ( $sth->fetchall_arrayref( {} ), $total_rows );
}
=head1 OTHER FUNCTIONS
=head2 _find_value
@ -1302,7 +1330,6 @@ sub _find_value {
return ( $indicator, @result );
}
=head2 PrepareItemrecordDisplay
PrepareItemrecordDisplay($bibnum,$itemumber,$defaultvalues,$frameworkcode);
@ -1355,6 +1382,7 @@ sub PrepareItemrecordDisplay {
$query .= qq{ AND ( branchcode = ? OR branchcode IS NULL )} if $branch_limit;
$query .= qq{ ORDER BY lib};
my $authorised_values_sth = $dbh->prepare($query);
foreach my $tag ( sort keys %{$tagslib} ) {
if ( $tag ne '' ) {
@ -1363,7 +1391,8 @@ sub PrepareItemrecordDisplay {
foreach my $subfield (
sort { $a->{display_order} <=> $b->{display_order} || $a->{subfield} cmp $b->{subfield} }
grep { ref($_) && %$_ } # Not a subfield (values for "important", "lib", "mandatory", etc.) or empty
values %{ $tagslib->{$tag} } )
values %{ $tagslib->{$tag} }
)
{
next unless ( $subfield->{'tab'} );
next if ( $subfield->{'tab'} ne "10" );
@ -1390,6 +1419,7 @@ sub PrepareItemrecordDisplay {
$defaultvalue = q||;
} else {
$defaultvalue =~ s/"/&quot;/g;
# get today date & replace <<YYYY>>, <<MM>>, <<DD>> if provided in the default value
my $today_dt = dt_from_string;
my $year = $today_dt->strftime('%Y');
@ -1402,10 +1432,11 @@ sub PrepareItemrecordDisplay {
$defaultvalue =~ s/<<DD>>/$day/g;
# And <<USER>> with surname (?)
my $username =
( C4::Context->userenv
my $username = (
C4::Context->userenv
? C4::Context->userenv->{'surname'}
: "superlibrarian" );
: "superlibrarian"
);
$defaultvalue =~ s/<<USER>>/$username/g;
}
@ -1413,7 +1444,9 @@ sub PrepareItemrecordDisplay {
# search for itemcallnumber if applicable
if ( $subfield->{kohafield} eq 'items.itemcallnumber'
&& C4::Context->preference('itemcallnumber') && $itemrecord) {
&& C4::Context->preference('itemcallnumber')
&& $itemrecord )
{
foreach my $itemcn_pref ( split( /,/, C4::Context->preference('itemcallnumber') ) ) {
my $CNtag = substr( $itemcn_pref, 0, 3 );
next unless my $field = $itemrecord->field($CNtag);
@ -1425,39 +1458,48 @@ sub PrepareItemrecordDisplay {
}
if ( $subfield->{kohafield} eq 'items.itemcallnumber'
&& $defaultvalues
&& $defaultvalues->{'callnumber'} ) {
&& $defaultvalues->{'callnumber'} )
{
if ( $itemrecord and $defaultvalues and not $itemrecord->subfield( $tag, $subfield->{subfield} ) ) {
# if the item record exists, only use default value if the item has no callnumber
$defaultvalue = $defaultvalues->{callnumber};
} elsif ( !$itemrecord and $defaultvalues ) {
# if the item record *doesn't* exists, always use the default value
$defaultvalue = $defaultvalues->{callnumber};
}
}
if ( ( $subfield->{kohafield} eq 'items.holdingbranch' || $subfield->{kohafield} eq 'items.homebranch' )
&& $defaultvalues
&& $defaultvalues->{'branchcode'} ) {
&& $defaultvalues->{'branchcode'} )
{
if ( $itemrecord and $defaultvalues and not $itemrecord->subfield( $tag, $subfield ) ) {
$defaultvalue = $defaultvalues->{branchcode};
}
}
if ( ( $subfield->{kohafield} eq 'items.location' )
&& $defaultvalues
&& $defaultvalues->{'location'} ) {
&& $defaultvalues->{'location'} )
{
if ( $itemrecord and $defaultvalues and not $itemrecord->subfield( $tag, $subfield->{subfield} ) ) {
# if the item record exists, only use default value if the item has no locationr
$defaultvalue = $defaultvalues->{location};
} elsif ( !$itemrecord and $defaultvalues ) {
# if the item record *doesn't* exists, always use the default value
$defaultvalue = $defaultvalues->{location};
}
}
if ( ( $subfield->{kohafield} eq 'items.ccode' )
&& $defaultvalues
&& $defaultvalues->{'ccode'} ) {
&& $defaultvalues->{'ccode'} )
{
if ( !$itemrecord and $defaultvalues ) {
# if the item record *doesn't* exists, always use the default value
$defaultvalue = $defaultvalues->{ccode};
}
@ -1470,8 +1512,10 @@ sub PrepareItemrecordDisplay {
#---- branch
if ( $subfield->{'authorised_value'} eq "branches" ) {
if ( ( C4::Context->preference("IndependentBranches") )
&& !C4::Context->IsSuperLibrarian() ) {
my $sth = $dbh->prepare( "SELECT branchcode,branchname FROM branches WHERE branchcode = ? ORDER BY branchname" );
&& !C4::Context->IsSuperLibrarian() )
{
my $sth = $dbh->prepare(
"SELECT branchcode,branchname FROM branches WHERE branchcode = ? ORDER BY branchname");
$sth->execute( C4::Context->userenv->{branch} );
push @authorised_values, ""
unless ( $subfield->{mandatory} );
@ -1515,8 +1559,9 @@ sub PrepareItemrecordDisplay {
my $default_source = $defaultvalue || C4::Context->preference("DefaultClassificationSource");
foreach my $class_source ( sort keys %$class_sources ) {
next unless $class_sources->{$class_source}->{'used'} or
($class_source eq $default_source);
next
unless $class_sources->{$class_source}->{'used'}
or ( $class_source eq $default_source );
push @authorised_values, $class_source;
$authorised_lib{$class_source} = $class_sources->{$class_source}->{'description'};
}
@ -1542,44 +1587,55 @@ sub PrepareItemrecordDisplay {
labels => \%authorised_lib,
};
} elsif ( $subfield->{value_builder} ) {
# it is a plugin
require Koha::FrameworkPlugin;
my $plugin = Koha::FrameworkPlugin->new({
my $plugin = Koha::FrameworkPlugin->new(
{
name => $subfield->{value_builder},
item_style => 1,
});
}
);
my $pars = { dbh => $dbh, record => undef, tagslib => $tagslib, id => $subfield_data{id} };
$plugin->build($pars);
if ( $itemrecord and my $field = $itemrecord->field($tag) ) {
$defaultvalue = $field->subfield( $subfield->{subfield} ) || q{};
}
if ( !$plugin->errstr ) {
#TODO Move html to template; see report 12176/13397
my $tab = $plugin->noclick ? '-1' : '';
my $class = $plugin->noclick ? ' disabled' : '';
my $title = $plugin->noclick ? 'No popup' : 'Tag editor';
$subfield_data{marc_value} = qq[<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" /><a href="#" id="buttonDot_$subfield_data{id}" class="buttonDot $class" title="$title">...</a>\n].$plugin->javascript;
$subfield_data{marc_value} =
qq[<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" /><a href="#" id="buttonDot_$subfield_data{id}" class="buttonDot $class" title="$title">...</a>\n]
. $plugin->javascript;
} else {
warn $plugin->errstr;
$subfield_data{marc_value} = qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />); # supply default input form
$subfield_data{marc_value} =
qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />)
; # supply default input form
}
}
elsif ( $tag eq '' ) { # it's an hidden field
$subfield_data{marc_value} = qq(<input type="hidden" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
}
elsif ( $subfield->{'hidden'} ) { # FIXME: shouldn't input type be "hidden" ?
$subfield_data{marc_value} = qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
}
elsif ( length($defaultvalue) > 100
or (C4::Context->preference("marcflavour") eq "UNIMARC" and
300 <= $tag && $tag < 400 && $subfield->{subfield} eq 'a' )
or (C4::Context->preference("marcflavour") eq "MARC21" and
500 <= $tag && $tag < 600 )
) {
} elsif ( $tag eq '' ) { # it's an hidden field
$subfield_data{marc_value} =
qq(<input type="hidden" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
} elsif ( $subfield->{'hidden'} ) { # FIXME: shouldn't input type be "hidden" ?
$subfield_data{marc_value} =
qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
} elsif (
length($defaultvalue) > 100
or ( C4::Context->preference("marcflavour") eq "UNIMARC"
and 300 <= $tag && $tag < 400 && $subfield->{subfield} eq 'a' )
or ( C4::Context->preference("marcflavour") eq "MARC21"
and 500 <= $tag && $tag < 600 )
)
{
# oversize field (textarea)
$subfield_data{marc_value} = qq(<textarea id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength">$defaultvalue</textarea>\n");
$subfield_data{marc_value} =
qq(<textarea id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength">$defaultvalue</textarea>\n");
} else {
$subfield_data{marc_value} = qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
$subfield_data{marc_value} =
qq(<input type="text" id="$subfield_data{id}" name="field_value" class="input_marceditor" size="50" maxlength="$maxlength" value="$defaultvalue" />);
}
push( @loop_data, \%subfield_data );
}

68
C4/Koha.pm
View File

@ -19,7 +19,6 @@ package C4::Koha;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Context;
@ -32,6 +31,7 @@ use Business::ISSN;
use autouse 'Data::cselectall_arrayref' => qw(Dumper);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -89,6 +89,7 @@ The categories must be part of Authorized Values (ITEMTYPECAT)
sub GetItemTypesCategorized {
my $dbh = C4::Context->dbh;
# Order is important, so that partially hidden (some items are not visible in OPAC) search
# categories will be visible. hideinopac=0 must be last.
my $query = q|
@ -237,10 +238,13 @@ sub getImageSets {
my %params = @_;
my $checked = $params{'checked'} || '';
my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
my $paths = {
staff => {
filesystem => getitemtypeimagedir('intranet'),
url => getitemtypeimagesrc('intranet'),
},
opac => { filesystem => getitemtypeimagedir('opac'),
opac => {
filesystem => getitemtypeimagedir('opac'),
url => getitemtypeimagesrc('opac'),
}
};
@ -249,11 +253,14 @@ sub getImageSets {
my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
foreach my $imagesubdir (@subdirectories) {
my @imagelist = (); # hashrefs of image info
my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
my @imagenames =
_getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
my $imagesetactive = 0;
foreach my $thisimage (@imagenames) {
push( @imagelist,
{ KohaImage => "$imagesubdir/$thisimage",
push(
@imagelist,
{
KohaImage => "$imagesubdir/$thisimage",
StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
@ -261,9 +268,11 @@ sub getImageSets {
);
$imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
}
push @imagesets, { imagesetname => $imagesubdir,
push @imagesets, {
imagesetname => $imagesubdir,
imagesetactive => $imagesetactive,
images => \@imagelist };
images => \@imagelist
};
}
return \@imagesets;
@ -297,8 +306,7 @@ sub getallthemes {
my @themes;
if ( $type eq 'intranet' ) {
$htdocs = C4::Context->config('intrahtdocs');
}
else {
} else {
$htdocs = C4::Context->config('opachtdocs');
}
my $dir_h;
@ -352,8 +360,7 @@ sub getFacets {
}
];
unless ( Koha::Libraries->search->count == 1 )
{
unless ( Koha::Libraries->search->count == 1 ) {
my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
if ( $DisplayLibraryFacets eq 'both'
|| $DisplayLibraryFacets eq 'holding' )
@ -381,8 +388,7 @@ sub getFacets {
);
}
}
}
else {
} else {
$facets = [
{
idx => 'su-to',
@ -390,6 +396,7 @@ sub getFacets {
tags => [qw/ 650a /],
sep => '--',
},
# {
# idx => 'su-na',
# label => 'People and Organizations',
@ -438,8 +445,7 @@ sub getFacets {
}
];
unless ( Koha::Libraries->search->count == 1 )
{
unless ( Koha::Libraries->search->count == 1 ) {
my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
if ( $DisplayLibraryFacets eq 'both'
|| $DisplayLibraryFacets eq 'holding' )
@ -488,10 +494,8 @@ sub GetAuthorisedValues {
my $opac = shift ? 1 : 0; # normalise to be safe
# Is this cached already?
my $branch_limit =
C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
my $cache_key =
"AuthorisedValues-$category-$opac-$branch_limit";
my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
my $cache_key = "AuthorisedValues-$category-$opac-$branch_limit";
my $cache = Koha::Caches->get_instance();
my $result = $cache->get_from_cache($cache_key);
return $result if $result;
@ -507,6 +511,7 @@ sub GetAuthorisedValues {
} if $branch_limit;
my @where_strings;
my @where_args;
if ($category) {
push @where_strings, "category = ?";
push @where_args, $category;
@ -518,8 +523,10 @@ sub GetAuthorisedValues {
if ( @where_strings > 0 ) {
$query .= " WHERE " . join( " AND ", @where_strings );
}
$query .= ' ORDER BY category, ' . (
$opac ? 'COALESCE(lib_opac, lib)'
$query .= ' ORDER BY category, '
. (
$opac
? 'COALESCE(lib_opac, lib)'
: 'lib, lib_opac'
);
@ -593,8 +600,7 @@ sub GetNormalizedUPC {
}
}
}
else { # assume marc21 if not unimarc
} else { # assume marc21 if not unimarc
my @fields = $marcrecord->field('024');
foreach my $field (@fields) {
my $indicator = $field->indicator(1);
@ -611,6 +617,7 @@ sub GetNormalizedUPC {
sub GetNormalizedISBN {
my ( $isbn, $marcrecord, $marcflavour ) = @_;
if ($isbn) {
# Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
# anything after " | " should be removed, along with the delimiter
($isbn) = split( /\|/, $isbn );
@ -627,8 +634,7 @@ sub GetNormalizedISBN {
return _isbn_cleanup($isbn);
}
}
}
else { # assume marc21 if not unimarc
} else { # assume marc21 if not unimarc
my @fields = $marcrecord->field('020');
foreach my $field (@fields) {
$isbn = $field->subfield('a');
@ -652,8 +658,7 @@ sub GetNormalizedEAN {
return $ean;
}
}
}
else { # assume marc21 if not unimarc
} else { # assume marc21 if not unimarc
my @fields = $marcrecord->field('024');
foreach my $field (@fields) {
my $indicator = $field->indicator(1);
@ -681,6 +686,7 @@ sub GetNormalizedOCLCNumber {
}
}
} else {
# TODO for UNIMARC
}
}
@ -739,8 +745,7 @@ sub NormalizeISBN {
if ( $format eq 'ISBN-10' ) {
$isbn = $isbn->as_isbn10();
}
elsif ( $format eq 'ISBN-13' ) {
} elsif ( $format eq 'ISBN-13' ) {
$isbn = $isbn->as_isbn13();
}
return unless $isbn;
@ -838,8 +843,7 @@ sub NormalizeISSN {
if ($strip_hyphen) {
$string = $issn->_issn;
}
else {
} else {
$string = $issn->as_string;
}
return $string;

4
C4/Labels/Batch.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Batch);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

130
C4/Labels/Label.pm
View File

@ -53,8 +53,7 @@ sub _check_params {
$exit_code = 1;
}
}
}
else {
} else {
if ( !( grep m/$_/, @valid_label_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
@ -65,8 +64,10 @@ sub _check_params {
sub _guide_box {
my ( $llx, $lly, $width, $height ) = @_;
return unless ( defined $llx and defined $lly and
defined $width and defined $height );
return unless ( defined $llx
and defined $lly
and defined $width
and defined $height );
my $obj_stream = "q\n"; # save the graphic state
$obj_stream .= "0.5 w\n"; # border line width
$obj_stream .= "1.0 0.0 0.0 RG\n"; # border color red
@ -81,15 +82,19 @@ sub _get_label_item {
my $item_number = shift;
my $barcode_only = shift || 0;
my $dbh = C4::Context->dbh;
# FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
# Something like this, perhaps, but this also causes problems because we need more fields sometimes.
# SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
my $sth = $dbh->prepare("SELECT bi.*, i.*, b.*,br.* FROM items AS i, biblioitems AS bi ,biblio AS b, branches AS br WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber AND i.homebranch=br.branchcode;");
my $sth = $dbh->prepare(
"SELECT bi.*, i.*, b.*,br.* FROM items AS i, biblioitems AS bi ,biblio AS b, branches AS br WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber AND i.homebranch=br.branchcode;"
);
$sth->execute($item_number);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
}
my $data = $sth->fetchrow_hashref;
# Replaced item's itemtype with the more user-friendly description...
my $sth1 = $dbh->prepare("SELECT itemtype,description FROM itemtypes WHERE itemtype = ?");
$sth1->execute( $data->{'itemtype'} );
@ -99,16 +104,25 @@ sub _get_label_item {
my $data1 = $sth1->fetchrow_hashref;
$data->{'itemtype'} = $data1->{'description'};
$data->{'itype'} = $data1->{'description'};
# add *_description fields
if ( $data->{'homebranch'} || $data->{'holdingbranch'} ) {
require Koha::Libraries;
# FIXME Is this used??
$data->{'homebranch_description'} = Koha::Libraries->find($data->{'homebranch'})->branchname if $data->{'homebranch'};
$data->{'holdingbranch_description'} = Koha::Libraries->find($data->{'holdingbranch'})->branchname if $data->{'holdingbranch'};
$data->{'homebranch_description'} = Koha::Libraries->find( $data->{'homebranch'} )->branchname
if $data->{'homebranch'};
$data->{'holdingbranch_description'} = Koha::Libraries->find( $data->{'holdingbranch'} )->branchname
if $data->{'holdingbranch'};
}
$data->{'ccode_description'} = C4::Biblio::GetAuthorisedValueDesc('','', $data->{'ccode'} ,'','','CCODE', 1) if $data->{'ccode'};
$data->{'location_description'} = C4::Biblio::GetAuthorisedValueDesc('','', $data->{'location'} ,'','','LOC', 1) if $data->{'location'};
$data->{'permanent_location_description'} = C4::Biblio::GetAuthorisedValueDesc('','', $data->{'permanent_location'} ,'','','LOC', 1) if $data->{'permanent_location'};
$data->{'ccode_description'} = C4::Biblio::GetAuthorisedValueDesc( '', '', $data->{'ccode'}, '', '', 'CCODE', 1 )
if $data->{'ccode'};
$data->{'location_description'} =
C4::Biblio::GetAuthorisedValueDesc( '', '', $data->{'location'}, '', '', 'LOC', 1 )
if $data->{'location'};
$data->{'permanent_location_description'} =
C4::Biblio::GetAuthorisedValueDesc( '', '', $data->{'permanent_location'}, '', '', 'LOC', 1 )
if $data->{'permanent_location'};
$barcode_only ? return $data->{'barcode'} : return $data;
}
@ -143,12 +157,12 @@ sub _get_barcode_data {
my $err = '';
$f =~ s/^\s?//;
if ( $f =~ /^'(.*)'.*/ ) {
# single quotes indicate a static text string.
$datastring .= $1;
$f = $';
next FIELD_LIST;
}
elsif ( $f =~ /^($match_kohatable).*/ ) {
} elsif ( $f =~ /^($match_kohatable).*/ ) {
my @fields = split ' ', $f;
my @data;
for my $field (@fields) {
@ -159,8 +173,7 @@ sub _get_barcode_data {
$datastring .= join ' ', @data;
$f = $';
next FIELD_LIST;
}
elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
} elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
my ( $field, $subf, $ws ) = ( $1, $2, $3 );
my ( $itemtag, $itemsubfieldcode ) = &GetMarcFromKohaField("items.itemnumber");
my @marcfield = $record->field($field);
@ -171,8 +184,7 @@ sub _get_barcode_data {
if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
if ( $itemfield->subfield($subf) ) {
$datastring .= $itemfield->subfield($subf) . $ws;
}
else {
} else {
warn sprintf( "The '%s' field contains no data.", $f );
}
last ITEM_FIELDS;
@ -181,16 +193,14 @@ sub _get_barcode_data {
} else { # bib-level data, we'll take the first matching tag/subfield.
if ( $marcfield[0]->subfield($subf) ) {
$datastring .= $marcfield[0]->subfield($subf) . $ws;
}
else {
} else {
warn sprintf( "The '%s' field contains no data.", $f );
}
}
}
$f = $';
next FIELD_LIST;
}
else {
} else {
warn sprintf( 'Failed to parse label format string: %s', $f );
last FIELD_LIST; # Failed to match
}
@ -218,7 +228,8 @@ sub _desc_koha_tables {
sub _BIB {
my $self = shift;
my $line_spacer = ($self->{'font_size'} * 1); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.).
my $line_spacer = ( $self->{'font_size'} * 1 )
; # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.).
my $text_lly = ( $self->{'lly'} + ( $self->{'height'} - $self->{'top_text_margin'} ) );
return $self->{'llx'}, $text_lly, $line_spacer, 0, 0, 0, 0;
}
@ -330,8 +341,7 @@ sub get_attr {
my ($attr) = @_;
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
return;
@ -343,17 +353,20 @@ sub create_label {
my ( $text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor );
{
my $sub = \&{ '_' . $self->{printing_type} };
($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor) = $sub->($self); # an obfuscated call to the correct printing type sub
( $text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor ) =
$sub->($self); # an obfuscated call to the correct printing type sub
}
if ( $self->{'printing_type'} =~ /BIB/ ) {
$label_text = draw_label_text( $self,
$label_text = draw_label_text(
$self,
llx => $text_llx,
lly => $text_lly,
line_spacer => $line_spacer,
);
}
if ( $self->{'printing_type'} =~ /BAR/ ) {
barcode( $self,
barcode(
$self,
llx => $barcode_llx,
lly => $barcode_lly,
width => $barcode_width,
@ -374,34 +387,35 @@ sub draw_label_text {
my $label_fields = _get_text_fields( $self->{'format_string'} );
my $biblio = Koha::Biblios->find( $item->{biblionumber} );
my $record = $biblio->metadata->record;
# FIXME - returns all items, so you can't get data from an embedded holdings field.
# TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
my $cn_source = ($item->{'cn_source'} ? $item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
my $cn_source =
( $item->{'cn_source'} ? $item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource') );
my $class_source = Koha::ClassSources->find($cn_source);
my ( $split_routine, $regexs );
if ($class_source) {
my $class_split_rule = Koha::ClassSplitRules->find( $class_source->class_split_rule );
$split_routine = $class_split_rule->split_routine;
$regexs = $class_split_rule->regexs;
} else {
$split_routine = $cn_source;
}
else { $split_routine = $cn_source }
LABEL_FIELDS: # process data for requested fields on current label
for my $field (@$label_fields) {
if ( $field->{'code'} eq 'itemtype' ) {
$field->{'data'} = C4::Context->preference('item-level_itypes') ? $item->{'itype'} : $item->{'itemtype'};
}
else {
} else {
$field->{'data'} = _get_barcode_data( $field->{'code'}, $item, $record );
}
# Find appropriate font it oblique title selected, except main font is oblique
if ( ( $field->{'code'} eq 'title' ) and ( $self->{'oblique_title'} == 1 ) ) {
if ( $font =~ /^TB$/ ) {
$font .= 'I';
}
elsif ( $font =~ /^TR$/ ) {
} elsif ( $font =~ /^TR$/ ) {
$font = 'TI';
}
elsif ( $font !~ /^T/ and $font !~ /O$/ ) {
} elsif ( $font !~ /^T/ and $font !~ /O$/ ) {
$font .= 'O';
}
}
@ -411,12 +425,17 @@ sub draw_label_text {
$field_data =~ s/\r//g;
}
my @label_lines;
# Fields which hold call number data FIXME: ( 060? 090? 092? 099? )
my @callnumber_list = qw(itemcallnumber 050a 050b 082a 952o 995k);
if ((grep {$field->{'code'} =~ m/$_/} @callnumber_list) and ($self->{'printing_type'} ne 'BAR') and ($self->{'callnum_split'})) { # If the field contains the call number, we do some sp
if ( ( grep { $field->{'code'} =~ m/$_/ } @callnumber_list )
and ( $self->{'printing_type'} ne 'BAR' )
and ( $self->{'callnum_split'} ) )
{ # If the field contains the call number, we do some sp
if ( $split_routine eq 'LCC' || $split_routine eq 'nlm' ) { # NLM and LCC should be split the same way
@label_lines = C4::ClassSplitRoutine::LCC::split_callnumber($field_data);
@label_lines = C4::ClassSplitRoutine::Generic::split_callnumber($field_data) unless @label_lines; # If it was not a true lccn, try it as a custom call number
@label_lines = C4::ClassSplitRoutine::Generic::split_callnumber($field_data)
unless @label_lines; # If it was not a true lccn, try it as a custom call number
push( @label_lines, $field_data ) unless @label_lines; # If it was not that, send it on unsplit
} elsif ( $split_routine eq 'Dewey' ) {
@label_lines = C4::ClassSplitRoutine::Dewey::split_callnumber($field_data);
@ -427,19 +446,23 @@ sub draw_label_text {
@label_lines = C4::ClassSplitRoutine::Generic::split_callnumber($field_data) unless @label_lines;
push( @label_lines, $field_data ) unless @label_lines;
} else {
warn sprintf('Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha-community.org', $field_data);
warn sprintf(
'Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha-community.org',
$field_data
);
push @label_lines, $field_data;
}
}
else {
} else {
if ($field_data) {
$field_data =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
$field_data =~
s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
# Escaping the parens was causing odd output, see bug 13124
# $field_data =~ s/\(/\\\(/g; # Escape '(' and ')' for the pdf object stream...
# $field_data =~ s/\)/\\\)/g;
}
eval { $Text::Wrap::columns = $self->{'text_wrap_cols'}; };
my @line = split( /\n/, wrap( '', '', $field_data ) );
# If this is a title field, limit to two lines; all others limit to one... FIXME: this is rather arbitrary
if ( $field->{'code'} eq 'title' && scalar(@line) >= 2 ) {
while ( scalar(@line) > 2 ) {
@ -459,13 +482,12 @@ sub draw_label_text {
my $string_width = C4::Creators::PDF->StrWidth( $line, $font, $self->{'font_size'} );
if ( $self->{'justify'} eq 'R' ) {
$text_llx = $params{'llx'} + $self->{'width'} - ( $self->{'left_text_margin'} + $string_width );
}
elsif($self->{'justify'} eq 'C') {
} elsif ( $self->{'justify'} eq 'C' ) {
# some code to try and center each line on the label based on font size and string point width...
my $whitespace = ( $self->{'width'} - ( $string_width + ( 2 * $self->{'left_text_margin'} ) ) );
$text_llx = ( ( $whitespace / 2 ) + $params{'llx'} + $self->{'left_text_margin'} );
}
else {
} else {
$text_llx = ( $params{'llx'} + $self->{'left_text_margin'} );
}
push @label_text, {
@ -489,7 +511,8 @@ sub draw_guide_box {
sub barcode {
my $self = shift;
my %params = @_;
$params{'barcode_data'} = ($self->{'barcode'} || _get_label_item($self->{'item_number'}, 1)) if !$params{'barcode_data'};
$params{'barcode_data'} = ( $self->{'barcode'} || _get_label_item( $self->{'item_number'}, 1 ) )
if !$params{'barcode_data'};
$params{'barcode_type'} = $self->{'barcode_type'} if !$params{'barcode_type'};
my $x_scale_factor = 1;
my $num_of_bars = length( $params{'barcode_data'} );
@ -497,6 +520,7 @@ sub barcode {
my $bar_length = 0;
my $guard_length = 10;
my $hide_text = 'yes';
if ( $params{'barcode_type'} =~ m/CODE39/ ) {
$bar_length = '17.5';
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
@ -504,8 +528,7 @@ sub barcode {
if ( $params{'barcode_type'} eq 'CODE39MOD' ) {
my $c39 = CheckDigits('code_39'); # get modulo43 checksum
$params{'barcode_data'} = $c39->complete( $params{'barcode_data'} );
}
elsif ($params{'barcode_type'} eq 'CODE39MOD10') {
} elsif ( $params{'barcode_type'} eq 'CODE39MOD10' ) {
my $c39_10 = CheckDigits('siret'); # get modulo43 checksum
$params{'barcode_data'} = $c39_10->complete( $params{'barcode_data'} );
$hide_text = '';
@ -525,8 +548,7 @@ sub barcode {
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
elsif ($params{'barcode_type'} eq 'COOP2OF5') {
} elsif ( $params{'barcode_type'} eq 'COOP2OF5' ) {
$bar_length = '9.43333333333333';
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
@ -543,8 +565,7 @@ sub barcode {
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
elsif ( $params{'barcode_type'} eq 'INDUSTRIAL2OF5' ) {
} elsif ( $params{'barcode_type'} eq 'INDUSTRIAL2OF5' ) {
$bar_length = '13.1333333333333';
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
@ -561,8 +582,7 @@ sub barcode {
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
elsif ($params{'barcode_type'} eq 'EAN13') {
} elsif ( $params{'barcode_type'} eq 'EAN13' ) {
$bar_length = 4; # FIXME
$num_of_bars = 13;
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
@ -572,6 +592,7 @@ sub barcode {
x => $params{'llx'},
y => $params{'lly'},
value => sprintf( '%013d', $params{barcode_data} ),
# xSize => $x_scale_factor,
# ySize => $params{'y_scale_factor'},
mode => 'graphic',
@ -580,8 +601,7 @@ sub barcode {
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
else {
} else {
warn "unknown barcode_type: $params{barcode_type}";
}
}

4
C4/Labels/Layout.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Layout);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

4
C4/Labels/Profile.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Profile);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

1
C4/Labels/Template.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Template);
use autouse 'Data::Dumper' => qw(Dumper);
use constant TEMPLATE_TABLE => 'creator_templates';
__PACKAGE__ =~ m/^C4::(.+)::.+$/;

107
C4/Languages.pm
View File

@ -18,7 +18,6 @@ package C4::Languages;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use strict;
use warnings;
@ -31,6 +30,7 @@ use Koha::Cache::Memory::Lite;
use Koha::Language;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -40,7 +40,8 @@ BEGIN {
getLanguages
getAllLanguages
);
push @EXPORT_OK, qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage get_rfc4646_from_iso639);
push @EXPORT_OK,
qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage get_rfc4646_from_iso639);
}
=head1 NAME
@ -71,6 +72,7 @@ Returns a reference to an array of hashes:
=cut
sub getFrameworkLanguages {
# get a hash with all language codes, names, and locale names
my $all_languages = getAllLanguages();
my @languages;
@ -90,7 +92,8 @@ sub getFrameworkLanguages {
push @languages, {
'language_code' => $dirname,
'language_description' => $language_set->{language_description},
'native_descrition'=>$language_set->{language_native_description} }
'native_descrition' => $language_set->{language_native_description}
};
}
}
}
@ -137,8 +140,7 @@ sub getTranslatedLanguages {
@languages = _get_opac_language_dirs( $htdocs, $theme );
$cache->set_in_cache( $cache_key, \@languages );
}
}
elsif ($interface && $interface eq 'intranet' ) {
} elsif ( $interface && $interface eq 'intranet' ) {
my $htdocs = C4::Context->config('intrahtdocs');
my $cached = $cache->get_from_cache($cache_key);
if ($cached) {
@ -147,8 +149,7 @@ sub getTranslatedLanguages {
@languages = _get_intranet_language_dirs( $htdocs, $theme );
$cache->set_in_cache( $cache_key, \@languages );
}
}
else {
} else {
my $htdocs = C4::Context->config('intrahtdocs');
push @languages, _get_intranet_language_dirs($htdocs);
@ -280,8 +281,7 @@ sub _get_opac_language_dirs {
my @languages;
if ( $theme and -d "$htdocs/$theme" ) {
(@languages) = _get_language_dirs( $htdocs, $theme );
}
else {
} else {
for my $theme ( _get_themes('opac') ) {
push @languages, _get_language_dirs( $htdocs, $theme );
}
@ -289,15 +289,13 @@ sub _get_opac_language_dirs {
return @languages;
}
sub _get_intranet_language_dirs {
my ( $htdocs, $theme ) = @_;
my @languages;
if ( $theme and -d "$htdocs/$theme" ) {
@languages = _get_language_dirs( $htdocs, $theme );
}
else {
} else {
foreach my $theme ( _get_themes('intranet') ) {
push @languages, _get_language_dirs( $htdocs, $theme );
}
@ -320,14 +318,14 @@ sub _get_themes {
my @themes;
if ( $interface && $interface eq 'intranet' ) {
$htdocs = C4::Context->config('intrahtdocs');
}
else {
} else {
$htdocs = C4::Context->config('opachtdocs');
}
my $dir_h;
opendir $dir_h, "$htdocs";
my @dirlist = readdir $dir_h;
foreach my $directory (@dirlist) {
# if there's an en dir, it's a valid theme
-d "$htdocs/$directory/en" and push @themes, $directory;
}
@ -377,17 +375,21 @@ sub _build_languages_arrayref {
my @translated_languages = @$translated_languages;
my @languages_loop; # the final reference to an array of hashrefs
my @enabled_languages = @$enabled_languages;
# how many languages are enabled, if one, take note, some contexts won't need to display it
my $language_groups;
my $track_language_groups;
my $current_language_regex = regex_lang_subtags($current_language);
# Loop through the translated languages
for my $translated_language (@translated_languages) {
# separate the language string into its subtag types
my $language_subtags_hashref = regex_lang_subtags($translated_language);
# is this language string 'enabled'?
for my $enabled_language (@enabled_languages) {
#warn "Checking out if $translated_language eq $enabled_language";
$language_subtags_hashref->{'enabled'} = 1 if $translated_language eq $enabled_language;
}
@ -395,13 +397,26 @@ sub _build_languages_arrayref {
# group this language, key by langtag
$language_subtags_hashref->{'sublanguage_current'} = 1 if $translated_language eq $current_language;
$language_subtags_hashref->{'rfc4646_subtag'} = $translated_language;
$language_subtags_hashref->{'native_description'} = language_get_description($language_subtags_hashref->{language},$language_subtags_hashref->{language},'language');
$language_subtags_hashref->{'script_description'} = language_get_description($language_subtags_hashref->{script},$language_subtags_hashref->{'language'},'script');
$language_subtags_hashref->{'region_description'} = language_get_description($language_subtags_hashref->{region},$language_subtags_hashref->{'language'},'region');
$language_subtags_hashref->{'variant_description'} = language_get_description($language_subtags_hashref->{variant},$language_subtags_hashref->{'language'},'variant');
$language_subtags_hashref->{'native_description'} = language_get_description(
$language_subtags_hashref->{language}, $language_subtags_hashref->{language},
'language'
);
$language_subtags_hashref->{'script_description'} = language_get_description(
$language_subtags_hashref->{script}, $language_subtags_hashref->{'language'},
'script'
);
$language_subtags_hashref->{'region_description'} = language_get_description(
$language_subtags_hashref->{region}, $language_subtags_hashref->{'language'},
'region'
);
$language_subtags_hashref->{'variant_description'} = language_get_description(
$language_subtags_hashref->{variant}, $language_subtags_hashref->{'language'},
'variant'
);
$track_language_groups->{ $language_subtags_hashref->{'language'} }++;
push( @{ $language_groups->{ $language_subtags_hashref->{language} } }, $language_subtags_hashref );
}
# $key is a language subtag like 'en'
my %idx = map { $enabled_languages->[$_] => $_ } reverse 0 .. @$enabled_languages - 1;
@ -412,8 +427,7 @@ sub _build_languages_arrayref {
my $bcount = @{ $language_groups->{$b} };
if ( $language_groups->{$a}->[0]->{enabled} ) {
$aa = $language_groups->{$a}->[0]->{rfc4646_subtag};
}
elsif ( $acount > 1 ) {
} elsif ( $acount > 1 ) {
for ( my $i = 1 ; $i < $acount ; $i++ ) {
if ( $language_groups->{$a}->[$i]->{enabled} ) {
$aa = $language_groups->{$a}->[$i]->{rfc4646_subtag};
@ -423,8 +437,7 @@ sub _build_languages_arrayref {
}
if ( $language_groups->{$b}->[0]->{enabled} ) {
$bb = $language_groups->{$b}->[0]->{rfc4646_subtag};
}
elsif ( $bcount > 1 ) {
} elsif ( $bcount > 1 ) {
for ( my $i = 1 ; $i < $bcount ; $i++ ) {
if ( $language_groups->{$b}->[$i]->{enabled} ) {
$bb = $language_groups->{$b}->[$i]->{rfc4646_subtag};
@ -432,15 +445,14 @@ sub _build_languages_arrayref {
}
}
}
( exists $idx{$aa}
and exists $idx{$bb}
and ( $idx{$aa} cmp $idx{$bb} ) )
( exists $idx{$aa} and exists $idx{$bb} and ( $idx{$aa} cmp $idx{$bb} ) )
|| ( exists $idx{$aa} and exists $idx{$bb} )
|| exists $idx{$bb}
} keys %$language_groups;
for my $key (@ordered_keys) {
my $value = $language_groups->{$key};
# is this language group enabled? are any of the languages within it enabled?
my $enabled;
for my $enabled_language (@enabled_languages) {
@ -448,6 +460,7 @@ sub _build_languages_arrayref {
$enabled = 1 if $key eq ( $regex_enabled_language->{language} // '' );
}
push @languages_loop, {
# this is only use if there is one
rfc4646_subtag => @$value[0]->{rfc4646_subtag},
native_description => language_get_description( $key, $key, 'language' ),
@ -466,6 +479,7 @@ sub language_get_description {
my $dbh = C4::Context->dbh;
my $desc;
my $sth = $dbh->prepare("SELECT description FROM language_descriptions WHERE subtag=? AND lang=? AND type=?");
#warn "QUERY: SELECT description FROM language_descriptions WHERE subtag=$script AND lang=$lang AND type=$type";
$sth->execute( $script, $lang, $type );
while ( my $descriptions = $sth->fetchrow_hashref ) {
@ -480,6 +494,7 @@ sub language_get_description {
}
return $desc;
}
=head2 regex_lang_subtags
This internal sub takes a string composed according to RFC 4646 as
@ -512,6 +527,7 @@ sub regex_lang_subtags {
my $extlang = qr{(?: $s $alpha{3} )}x; # *3("-" 3ALPHA)
my $language = qr{(?: $alpha{2,3} | $alpha{4,8} )}x;
#my $language = qr{(?: $alpha{2,3}$extlang{0,3} | $alpha{4,8} )}x ; # (2*3ALPHA [ extlang ]) / 4ALPHA / 5*8ALPHA
my $script = qr{(?: $alpha{4} )}x; # 4ALPHA
@ -552,7 +568,9 @@ sub regex_lang_subtags {
#my $root = qr{(?: ($language) (?: $s ($script) )? 40% (?: $s ($region) )? 40% (?: $s ($variant) )? 10% (?: $s ($extension) )? 5% (?: $s ($privateuse) )? 5% ) 90% | ($grandfathered) 5% | ($privateuse) 5% };
$string =~ qr{^ (?:($language)) (?:$s($script))? (?:$s($region))? (?:$s($variant))? (?:$s($extension))? (?:$s($privateuse))? $}xi; # |($grandfathered) | ($privateuse) $}xi;
$string =~
qr{^ (?:($language)) (?:$s($script))? (?:$s($region))? (?:$s($variant))? (?:$s($extension))? (?:$s($privateuse))? $}xi
; # |($grandfathered) | ($privateuse) $}xi;
my %subtag = (
'rfc4646_subtag' => $string,
'language' => $1,
@ -577,35 +595,47 @@ sub get_bidi {
$bidi = $result->{'bidi'};
}
return $bidi;
};
}
sub accept_language {
# referenced http://search.cpan.org/src/CGILMORE/I18N-AcceptLanguage-1.04/lib/I18N/AcceptLanguage.pm
my ( $clientPreferences, $supportedLanguages ) = @_;
my @languages = ();
if ($clientPreferences) {
# There should be no whitespace anways, but a cleanliness/sanity check
$clientPreferences =~ s/\s//g;
# Prepare the list of client-acceptable languages
foreach my $tag ( split( /,/, $clientPreferences ) ) {
my ( $language, $quality ) = split( /\;/, $tag );
$quality =~ s/^q=//i if $quality;
$quality = 1 unless $quality;
next if $quality <= 0;
# We want to force the wildcard to be last
$quality = 0 if ( $language eq '*' );
# Pushing lowercase language here saves processing later
push(@languages, { quality => $quality,
push(
@languages,
{
quality => $quality,
language => $language,
lclanguage => lc($language) });
lclanguage => lc($language)
}
);
}
} else {
carp "accept_language(x,y) called with no clientPreferences (x).";
}
# Prepare the list of server-supported languages
my %supportedLanguages = ();
my %secondaryLanguages = ();
foreach my $language (@$supportedLanguages) {
# warn "Language supported: " . $language->{language};
my $subtag = $language->{rfc4646_subtag};
$supportedLanguages{ lc($subtag) } = $subtag;
@ -619,21 +649,26 @@ sub accept_language {
my $secondaryMatch = '';
foreach my $tag (@languages) {
if ( exists( $supportedLanguages{ $tag->{lclanguage} } ) ) {
# Client en-us eq server en-us
return $supportedLanguages{ $tag->{language} } if exists( $supportedLanguages{ $tag->{language} } );
return $supportedLanguages{ $tag->{lclanguage} };
} elsif ( exists( $secondaryLanguages{ $tag->{lclanguage} } ) ) {
# Client en eq server en-us
return $secondaryLanguages{ $tag->{language} } if exists( $secondaryLanguages{ $tag->{language} } );
return $supportedLanguages{ $tag->{lclanguage} };
} elsif ( $tag->{lclanguage} =~ /^([^-]+)-/ && exists( $secondaryLanguages{$1} ) && $secondaryMatch eq '' ) {
# Client en-gb eq server en-us
$secondaryMatch = $secondaryLanguages{$1};
} elsif ( $tag->{lclanguage} =~ /^([^-]+)-/ && exists( $secondaryLanguages{$1} ) && $secondaryMatch eq '' ) {
# FIXME: We just checked the exact same conditional!
# Client en-us eq server en
$secondaryMatch = $supportedLanguages{$1};
} elsif ( $tag->{lclanguage} eq '*' ) {
# * matches every language not already specified.
# It doesn't care which we pick, so let's pick the default,
# if available, then the first in the array.
@ -641,6 +676,7 @@ sub accept_language {
return $supportedLanguages->[0];
}
}
# No primary matches. Secondary? (ie, en-us requested and en supported)
return $secondaryMatch if $secondaryMatch;
return; # else, we got nothing.
@ -690,8 +726,8 @@ sub getlanguage {
$cgi //= CGI->new;
$theme = C4::Context->preference( ( $interface eq 'opac' ) ? 'opacthemes' : 'template' );
my $preference_to_check =
$interface eq 'intranet' ? 'StaffInterfaceLanguages' : 'OPACLanguages';
my $preference_to_check = $interface eq 'intranet' ? 'StaffInterfaceLanguages' : 'OPACLanguages';
# Get the available/valid languages list
my $preference_value = C4::Context->preference($preference_to_check);
if ($preference_value) {
@ -715,8 +751,10 @@ sub getlanguage {
# HTTP_ACCEPT_LANGUAGE
if ( !$language && $ENV{HTTP_ACCEPT_LANGUAGE} ) {
$language = accept_language( $ENV{HTTP_ACCEPT_LANGUAGE},
getTranslatedLanguages( $interface, $theme ) );
$language = accept_language(
$ENV{HTTP_ACCEPT_LANGUAGE},
getTranslatedLanguages( $interface, $theme )
);
}
# Ignore a lang not selected in sysprefs
@ -743,7 +781,8 @@ sub getlanguage {
sub get_rfc4646_from_iso639 {
my $iso_code = shift;
my $rfc_subtag = Koha::Database->new()->schema->resultset('LanguageRfc4646ToIso639')->find({iso639_2_code=>$iso_code});
my $rfc_subtag =
Koha::Database->new()->schema->resultset('LanguageRfc4646ToIso639')->find( { iso639_2_code => $iso_code } );
if ($rfc_subtag) {
return $rfc_subtag->rfc4646_subtag;
} else {

295
C4/Letters.pm
View File

@ -45,6 +45,7 @@ use Koha::Template::Plugin::KohaDates;
use constant SERIALIZED_EMAIL_CONTENT_TYPE => 'message/rfc822';
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -210,13 +211,16 @@ sub GetLettersAvailableForALibrary {
$letters{ $l->{code} } = $l;
}
for my $l (@$specific_letters) {
# Overwrite the default letter with the specific one.
$letters{ $l->{code} } = $l;
}
return [ map { $letters{$_} }
return [
map { $letters{$_} }
sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
keys %letters ];
keys %letters
];
}
@ -244,15 +248,16 @@ sub DelLetter {
my $mtt = $params->{mtt};
my $lang = $params->{lang};
my $dbh = C4::Context->dbh;
$dbh->do(q|
$dbh->do(
q|
DELETE FROM letter
WHERE branchcode = ?
AND module = ?
AND code = ?
|
. ( $mtt ? q| AND message_transport_type = ?| : q|| )
. ( $lang? q| AND lang = ?| : q|| )
, undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
. ( $mtt ? q| AND message_transport_type = ?| : q|| ) . ( $lang ? q| AND lang = ?| : q|| ), undef,
$branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () )
);
}
=head2 SendAlerts
@ -287,18 +292,14 @@ sub SendAlerts {
# prepare the letter...
# search the subscriptionid
my $sth =
$dbh->prepare(
"SELECT subscriptionid FROM serial WHERE serialid=?");
my $sth = $dbh->prepare("SELECT subscriptionid FROM serial WHERE serialid=?");
$sth->execute($externalid);
my ($subscriptionid) = $sth->fetchrow
or warn("No subscription for '$externalid'"),
return;
# search the biblionumber
$sth =
$dbh->prepare(
"SELECT biblionumber FROM subscription WHERE subscriptionid=?");
$sth = $dbh->prepare("SELECT biblionumber FROM subscription WHERE subscriptionid=?");
$sth->execute($subscriptionid);
my ($biblionumber) = $sth->fetchrow
or warn("No biblionumber for '$subscriptionid'"),
@ -342,15 +343,14 @@ sub SendAlerts {
if ( $letter->{is_html} ) {
$mail->html_body( _wrap_html( $letter->{content}, "" . $letter->{title} ) );
}
else {
} else {
$mail->text_body( $letter->{content} );
}
my $success = try {
$mail->send_or_die( { transport => $library->smtp_server->transport } );
}
catch {
} catch {
# We expect ref($_) eq 'Email::Sender::Failure'
$error = $_->message;
@ -361,8 +361,7 @@ sub SendAlerts {
return { error => $error }
unless $success;
}
}
elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
} elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
# prepare the letter...
my $strsth;
@ -436,9 +435,7 @@ sub SendAlerts {
$sthorders = $dbh->prepare($strsth);
$sthorders->execute($basketno);
$dataorders = $sthorders->fetchall_arrayref( {} );
%loops = (
aqorders => [ map { $_->{ordernumber} } @$dataorders ]
);
%loops = ( aqorders => [ map { $_->{ordernumber} } @$dataorders ] );
}
my $booksellerid = $dataorders->[0]->{booksellerid};
@ -518,15 +515,14 @@ sub SendAlerts {
if ( $letter->{is_html} ) {
$mail->html_body( _wrap_html( $letter->{content}, "" . $letter->{title} ) );
}
else {
} else {
$mail->text_body( "" . $letter->{content} );
}
my $success = try {
$mail->send_or_die( { transport => $library->smtp_server->transport } );
}
catch {
} catch {
# We expect ref($_) eq 'Email::Sender::Failure'
$error = $_->message;
@ -543,12 +539,7 @@ sub SendAlerts {
$module,
$action,
$log_object,
"To="
. join( ',', @email )
. " Title="
. $letter->{title}
. " Content="
. $letter->{content}
"To=" . join( ',', @email ) . " Title=" . $letter->{title} . " Content=" . $letter->{content}
) if C4::Context->preference("ClaimsLog");
}
@ -626,6 +617,7 @@ sub GetPreparedLetter {
or carp("ERROR: nothing to substitute - all of 'objects', 'tables', 'loops' and 'substitute' are empty"),
return;
my $want_librarian = $params{want_librarian};
if ($want_librarian) {
my $userenv = C4::Context->userenv;
$objects->{librarian} = Koha::Patrons->find( C4::Context->userenv->{number} ) if ($userenv);
@ -681,6 +673,7 @@ sub GetPreparedLetter {
$letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
if ($want_librarian) {
# parsing librarian name
my $userenv = C4::Context->userenv;
$letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
@ -752,11 +745,11 @@ sub _substitute_tables {
my $values;
if ( $ref && $ref eq 'HASH' ) {
$values = $param;
}
else {
} else {
my $sth = _parseletter_sth($table);
unless ($sth) {
warn "_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
warn
"_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
return;
}
$sth->execute( $ref ? @$param : $param );
@ -776,37 +769,39 @@ sub _parseletter_sth {
carp "ERROR: _parseletter_sth() called without argument (table)";
return;
}
# NOTE: we used to check whether we had a statement handle cached in
# a %handles module-level variable. This was a dumb move and
# broke things for the rest of us. prepare_cached is a better
# way to cache statement handles anyway.
my $query =
($table eq 'accountlines' ) ? "SELECT * FROM $table WHERE accountlines_id = ?" :
($table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
($table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
($table eq 'tickets' ) ? "SELECT * FROM $table WHERE id = ?" :
($table eq 'ticket_updates' ) ? "SELECT * FROM $table WHERE id = ?" :
($table eq 'credits' ) ? "SELECT * FROM accountlines WHERE accountlines_id = ?" :
($table eq 'debits' ) ? "SELECT * FROM accountlines WHERE accountlines_id = ?" :
($table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
($table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
($table eq 'old_issues' ) ? "SELECT * FROM $table WHERE issue_id = ?" :
($table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
($table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?" :
($table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?" :
($table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?" :
($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE id = ?" :
($table eq 'aqorders' ) ? "SELECT * FROM $table WHERE ordernumber = ?" :
($table eq 'aqbasket' ) ? "SELECT * FROM $table WHERE basketno = ?" :
($table eq 'illrequests' ) ? "SELECT * FROM $table WHERE illrequest_id = ?" :
($table eq 'article_requests') ? "SELECT * FROM $table WHERE id = ?" :
($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
($table eq 'problem_reports') ? "SELECT * FROM $table WHERE reportid = ?" :
($table eq 'additional_contents' || $table eq 'opac_news') ? "SELECT * FROM additional_contents_localizations WHERE id = ?" :
($table eq 'recalls') ? "SELECT * FROM $table WHERE recall_id = ?" :
undef ;
( $table eq 'accountlines' ) ? "SELECT * FROM $table WHERE accountlines_id = ?"
: ( $table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?"
: ( $table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?"
: ( $table eq 'tickets' ) ? "SELECT * FROM $table WHERE id = ?"
: ( $table eq 'ticket_updates' ) ? "SELECT * FROM $table WHERE id = ?"
: ( $table eq 'credits' ) ? "SELECT * FROM accountlines WHERE accountlines_id = ?"
: ( $table eq 'debits' ) ? "SELECT * FROM accountlines WHERE accountlines_id = ?"
: ( $table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?"
: ( $table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?"
: ( $table eq 'old_issues' ) ? "SELECT * FROM $table WHERE issue_id = ?"
: ( $table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"
: ( $table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?"
: ( $table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?"
: ( $table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?"
: ( $table eq 'aqbooksellers' ) ? "SELECT * FROM $table WHERE id = ?"
: ( $table eq 'aqorders' ) ? "SELECT * FROM $table WHERE ordernumber = ?"
: ( $table eq 'aqbasket' ) ? "SELECT * FROM $table WHERE basketno = ?"
: ( $table eq 'illrequests' ) ? "SELECT * FROM $table WHERE illrequest_id = ?"
: ( $table eq 'article_requests' ) ? "SELECT * FROM $table WHERE id = ?"
: ( $table eq 'borrower_modifications' ) ? "SELECT * FROM $table WHERE verification_token = ?"
: ( $table eq 'subscription' ) ? "SELECT * FROM $table WHERE subscriptionid = ?"
: ( $table eq 'serial' ) ? "SELECT * FROM $table WHERE serialid = ?"
: ( $table eq 'problem_reports' ) ? "SELECT * FROM $table WHERE reportid = ?"
: ( $table eq 'additional_contents' || $table eq 'opac_news' )
? "SELECT * FROM additional_contents_localizations WHERE id = ?"
: ( $table eq 'recalls' ) ? "SELECT * FROM $table WHERE recall_id = ?"
: undef;
unless ($query) {
warn "ERROR: No _parseletter_sth query for table '$table'";
return; # nothing to get
@ -852,6 +847,7 @@ sub _parseletter {
while ( my ( $field, $val ) = each %$values ) {
$val =~ s/\p{P}$// if $val && $table =~ /biblio/;
#BZ 9886: Assuming that we want to eliminate ISBD punctuation here
#Therefore adding the test on biblio. This includes biblioitems,
#but excludes items. Removed unneeded global and lookahead.
@ -868,19 +864,23 @@ sub _parseletter {
and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
{
# If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
my $dateonly =
defined $1
? 0
: 1
; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
for my $letter_field (qw( title content )) {
my $filter_string_used = q{};
if ( $letter->{$letter_field} =~ $re_dateonly_filter ) {
# We overwrite $dateonly if the filter exists and we have a time in the datetime
$filter_string_used = $1 || q{};
$dateonly = $1 unless $dateonly;
}
my $replacedby_date = eval {
output_pref({ dt => scalar dt_from_string( $replacedby ), dateonly => $dateonly });
};
my $replacedby_date =
eval { output_pref( { dt => scalar dt_from_string($replacedby), dateonly => $dateonly } ); };
$replacedby_date //= q{};
if ( $letter->{$letter_field} ) {
@ -889,6 +889,7 @@ sub _parseletter {
}
}
}
# Other fields replacement
else {
for my $letter_field (qw( title content )) {
@ -948,6 +949,7 @@ sub EnqueueLetter {
my $params = shift or return;
return unless exists $params->{'letter'};
# return unless exists $params->{'borrowernumber'};
return unless exists $params->{'message_transport_type'};
@ -961,7 +963,8 @@ sub EnqueueLetter {
# If we have any attachments we should encode then into the body.
if ( $params->{'attachments'} ) {
$params->{'letter'} = _add_attachments(
{ letter => $params->{'letter'},
{
letter => $params->{'letter'},
attachments => $params->{'attachments'},
}
);
@ -1027,9 +1030,11 @@ sub SendQueuedMessages {
if ( exists( $params->{message_id} ) && !$params->{message_id} );
if ( C4::Context->config("enable_plugins") ) {
my @plugins = Koha::Plugins->new->GetPlugins({
my @plugins = Koha::Plugins->new->GetPlugins(
{
method => 'before_send_messages',
});
}
);
if (@plugins) {
foreach my $plugin (@plugins) {
@ -1046,16 +1051,24 @@ sub SendQueuedMessages {
my $smtp_transports = {};
my $count_messages = 0;
my $unsent_messages = Koha::Notice::Messages->search({
my $unsent_messages = Koha::Notice::Messages->search(
{
status => 'pending',
$params->{message_id} ? ( message_id => $params->{message_id} ) : (),
$params->{borrowernumber} ? ( borrowernumber => $params->{borrowernumber} ) : (),
# Check for scalar or array in letter_code and type
ref($params->{letter_code}) && @{$params->{letter_code}} ? ( letter_code => $params->{letter_code} ) : (),
ref( $params->{letter_code} )
&& @{ $params->{letter_code} } ? ( letter_code => $params->{letter_code} ) : (),
!ref( $params->{letter_code} ) && $params->{letter_code} ? ( letter_code => $params->{letter_code} ) : (),
ref($params->{type}) && @{$params->{type}} ? ( message_transport_type => $params->{type} ) : (), #TODO Existing inconsistency
!ref($params->{type}) && $params->{type} ? ( message_transport_type => $params->{type} ) : (), #TODO Existing inconsistency
});
ref( $params->{type} )
&& @{ $params->{type} }
? ( message_transport_type => $params->{type} )
: (), #TODO Existing inconsistency
!ref( $params->{type} )
&& $params->{type} ? ( message_transport_type => $params->{type} ) : (), #TODO Existing inconsistency
}
);
$unsent_messages = $unsent_messages->search( \$where ) if $where;
$domain_limits = Koha::Notice::Util->load_domain_limits; # (re)initialize per run
@ -1067,31 +1080,38 @@ sub SendQueuedMessages {
return unless $message_object->store;
# warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
warn sprintf( 'Processing %s message to patron: %s',
warn sprintf(
'Processing %s message to patron: %s',
$message->{'message_transport_type'},
$message->{'borrowernumber'} || 'Admin' )
if $params->{'verbose'};
$message->{'borrowernumber'} || 'Admin'
) if $params->{'verbose'};
# This is just begging for subclassing
next if ( lc( $message->{'message_transport_type'} ) eq 'rss' );
if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
my $rv = _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'}, $smtp_transports );
my $rv = _send_message_by_email(
$message, $params->{'username'}, $params->{'password'}, $params->{'method'},
$smtp_transports
);
$count_messages++ if $rv;
}
elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
} elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
my $patron = Koha::Patrons->find( $message->{borrowernumber} );
my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
unless ($sms_provider) {
warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'};
warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} )
if $params->{'verbose'};
_set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
next;
}
unless ( $patron->smsalertnumber ) {
_set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'};
warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} )
if $params->{'verbose'};
next;
}
$message->{to_address} = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
$message->{to_address} =
$patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
$message->{to_address} .= '@' . $sms_provider->domain();
# Check for possible from_address override
@ -1102,7 +1122,10 @@ sub SendQueuedMessages {
}
_update_message_to_address( $message->{'message_id'}, $message->{to_address} );
my $rv = _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
my $rv = _send_message_by_email(
$message, $params->{'username'}, $params->{'password'},
$params->{'method'}
);
$count_messages++ if $rv;
} else {
my $rv = _send_message_by_sms($message);
@ -1128,9 +1151,13 @@ sub GetRSSMessages {
return unless ref $params;
return unless $params->{'borrowernumber'};
return _get_unsent_messages( { message_transport_type => 'rss',
return _get_unsent_messages(
{
message_transport_type => 'rss',
limit => $params->{'limit'},
borrowernumber => $params->{'borrowernumber'}, } );
borrowernumber => $params->{'borrowernumber'},
}
);
}
=head2 GetPrintMessages
@ -1145,9 +1172,12 @@ person).
sub GetPrintMessages {
my $params = shift || {};
return _get_unsent_messages( { message_transport_type => 'print',
return _get_unsent_messages(
{
message_transport_type => 'print',
borrowernumber => $params->{'borrowernumber'},
} );
}
);
}
=head2 GetQueuedMessages ([$hashref])
@ -1219,11 +1249,13 @@ sub GetMessage {
my ($message_id) = @_;
return unless $message_id;
my $dbh = C4::Context->dbh;
return $dbh->selectrow_hashref(q|
return $dbh->selectrow_hashref(
q|
SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, updated_on, to_address, from_address, reply_address, content_type, failure_code
FROM message_queue
WHERE message_id = ?
|, {}, $message_id );
|, {}, $message_id
);
}
=head2 ResendMessage
@ -1247,14 +1279,18 @@ sub ResendMessage {
return unless $message;
my $rv = 0;
if ( $message->{status} ne 'pending' ) {
$rv = C4::Letters::_set_message_status({
$rv = C4::Letters::_set_message_status(
{
message_id => $message_id,
status => 'pending',
});
}
);
$rv = $rv > 0 ? 1 : 0;
# Clear destination email address to force address update
_update_message_to_address( $message_id, undef ) if $rv &&
$message->{message_transport_type} eq 'email';
_update_message_to_address( $message_id, undef )
if $rv
&& $message->{message_transport_type} eq 'email';
}
return $rv;
}
@ -1289,8 +1325,7 @@ sub _add_attachments {
if ( $letter->{is_html} ) {
$message->html_body( _wrap_html( $letter->{content}, $letter->{title} ) );
}
else {
} else {
$message->text_body( $letter->{content} );
}
@ -1345,7 +1380,8 @@ sub _get_unsent_messages {
push @query_params, $params->{'borrowernumber'};
}
if ( $params->{'letter_code'} ) {
my @letter_codes = ref $params->{'letter_code'} eq "ARRAY" ? @{$params->{'letter_code'}} : $params->{'letter_code'};
my @letter_codes =
ref $params->{'letter_code'} eq "ARRAY" ? @{ $params->{'letter_code'} } : $params->{'letter_code'};
if (@letter_codes) {
my $q = join( ",", ("?") x @letter_codes );
$statement .= " AND mq.letter_code IN ( $q ) ";
@ -1353,7 +1389,10 @@ sub _get_unsent_messages {
}
}
if ( $params->{'message_transport_type'} ) {
my @types = ref $params->{'message_transport_type'} eq "ARRAY" ? @{$params->{'message_transport_type'}} : $params->{'message_transport_type'};
my @types =
ref $params->{'message_transport_type'} eq "ARRAY"
? @{ $params->{'message_transport_type'} }
: $params->{'message_transport_type'};
if (@types) {
my $q = join( ",", ("?") x @types );
$statement .= " AND message_transport_type IN ( $q ) ";
@ -1388,6 +1427,7 @@ sub _send_message_by_email {
my @guarantor_address;
my $count_guarantor_address;
if ( C4::Context->preference('RedirectGuaranteeEmail') && $patron ) {
# Get guarantor addresses
my $guarantor_relationships = $patron->guarantor_relationships;
my @guarantors = $guarantor_relationships->guarantors->as_list;
@ -1413,7 +1453,8 @@ sub _send_message_by_email {
$to_address = $patron->notice_email_address;
}
if ( !$to_address && !$count_guarantor_address ) {
warn "FAIL: No 'to_address', email address or guarantors email address for borrowernumber ($message->{borrowernumber})";
warn
"FAIL: No 'to_address', email address or guarantors email address for borrowernumber ($message->{borrowernumber})";
_set_message_status(
{
message_id => $message->{'message_id'},
@ -1430,8 +1471,10 @@ sub _send_message_by_email {
$cc_address = join( ',', @guarantor_address );
_update_message_cc_address( $message->{'message_id'}, $cc_address );
# Skip this message if we exceed domain limits in this run
if ( Koha::Notice::Util->exceeds_limit( { to => $to_address, limits => $domain_limits } ) ) {
# Save the to_address if you delay the message so that we dont need to look it up again
_update_message_to_address( $message->{'message_id'}, $to_address )
if !$message->{to_address};
@ -1472,7 +1515,7 @@ sub _send_message_by_email {
}
);
return;
};
}
my $email;
try {
@ -1515,8 +1558,7 @@ sub _send_message_by_email {
$email->text_body($content);
}
}
}
catch {
} catch {
if ( ref($_) eq 'Koha::Exceptions::BadParameter' ) {
_set_message_status(
{
@ -1541,8 +1583,7 @@ sub _send_message_by_email {
my $smtp_server;
if ($library) {
$smtp_server = $library->smtp_server;
}
else {
} else {
$smtp_server = Koha::SMTP::Servers->get_default;
}
@ -1579,8 +1620,7 @@ sub _send_message_by_email {
}
);
return 1;
}
catch {
} catch {
_set_message_status(
{
message_id => $message->{'message_id'},
@ -1618,7 +1658,8 @@ EOS
sub _is_duplicate {
my ($message) = @_;
my $dbh = C4::Context->dbh;
my $count = $dbh->selectrow_array(q|
my $count = $dbh->selectrow_array(
q|
SELECT COUNT(*)
FROM message_queue
WHERE message_transport_type = ?
@ -1627,7 +1668,8 @@ sub _is_duplicate {
AND CAST(updated_on AS date) = CAST(NOW() AS date)
AND status="sent"
AND content = ?
|, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
|, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content}
);
return $count;
}
@ -1637,9 +1679,13 @@ sub _send_message_by_sms {
_update_message_to_address( $message->{message_id}, $patron->smsalertnumber ) if $patron;
unless ( $patron and $patron->smsalertnumber ) {
_set_message_status( { message_id => $message->{'message_id'},
_set_message_status(
{
message_id => $message->{'message_id'},
status => 'failed',
failure_code => 'MISSING_SMS' } );
failure_code => 'MISSING_SMS'
}
);
return;
}
@ -1669,8 +1715,7 @@ sub _send_message_by_sms {
failure_code => ''
}
);
}
else {
} else {
_set_message_status(
{
message_id => $message->{'message_id'},
@ -1711,9 +1756,11 @@ sub _set_message_status {
my $dbh = C4::Context->dbh();
my $statement = 'UPDATE message_queue SET status= ?, failure_code= ? WHERE message_id = ?';
my $sth = $dbh->prepare($statement);
my $result = $sth->execute( $params->{'status'},
my $result = $sth->execute(
$params->{'status'},
$params->{'failure_code'} || '',
$params->{'message_id'} );
$params->{'message_id'}
);
return $result;
}
@ -1750,7 +1797,8 @@ sub _process_tt {
}
) or die Template->error();
my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute, %$objects };
my $tt_params =
{ %{ _get_tt_params($tables) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute, %$objects };
$content = add_tt_filters($content);
$content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
@ -1760,8 +1808,7 @@ sub _process_tt {
$schema->txn_begin;
my $processed = try {
$template->process( \$content, $tt_params, \$output );
}
finally {
} finally {
$schema->txn_rollback;
};
croak "ERROR PROCESSING TEMPLATE: " . $template->error() unless $processed;
@ -1945,6 +1992,7 @@ sub _get_tt_params {
croak "ERROR processing table $table. Wrong API call.";
}
my $key = $pk ? $pk : $fk;
# $key does not come from user input
my $objects = $module->search(
{ $key => $values },
@ -1965,8 +2013,7 @@ sub _get_tt_params {
}
);
$params->{ $config->{$table}->{plural} } = $objects;
}
elsif ( $ref eq q{} || $ref eq 'HASH' ) {
} elsif ( $ref eq q{} || $ref eq 'HASH' ) {
my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
my $object;
if ($fk) { # Using a foreign key for lookup
@ -1983,19 +2030,16 @@ sub _get_tt_params {
$object = $module->find($id);
}
$params->{ $config->{$table}->{singular} } = $object;
}
else { # $ref eq 'ARRAY'
} else { # $ref eq 'ARRAY'
my $object;
if ( @{ $tables->{$table} } == 1 ) { # Param is a single key
$object = $module->search( { $pk => $tables->{$table} } )->last();
}
else { # Params are mutliple foreign keys
} else { # Params are mutliple foreign keys
croak "Multiple foreign keys (table $table) should be passed using an hashref";
}
$params->{ $config->{$table}->{singular} } = $object;
}
}
else {
} else {
croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
}
}
@ -2046,10 +2090,7 @@ sub get_item_content {
my @item_info = map {
$_ =~ /^date|date$/
? eval {
output_pref(
{ dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
}
? eval { output_pref( { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } ); }
: $item->{$_}
|| ''
} @$item_content_fields;

12
C4/Linker.pm
View File

@ -62,20 +62,17 @@ sub new {
while ( my ( $key, $value ) = each %$param ) {
if ( $key eq 'auth_limit' && $value ) {
my $dbh = C4::Context->dbh;
my $sql =
"SELECT authid FROM auth_header WHERE $value ORDER BY authid ASC";
my $sql = "SELECT authid FROM auth_header WHERE $value ORDER BY authid ASC";
my $sth = $dbh->prepare($sql);
$sth->execute();
while ( my ($authid) = $sth->fetchrow_array() ) {
push @{ $self->{'auths_to_link'} }, $authid;
}
}
elsif ( $key eq 'options' && $value ) {
} elsif ( $key eq 'options' && $value ) {
foreach my $opt ( split( /\|/, $value ) ) {
$self->{$opt} = 1;
}
}
elsif ($value) {
} elsif ($value) {
$self->{$key} = $value;
}
}
@ -96,8 +93,7 @@ sub _handle_auth_limit {
my $self = shift;
my $authid = shift;
if ( defined $self->{'auths_to_link'} && defined $authid && !grep { $_ == $authid }
@{ $self->{'auths_to_link'} } )
if ( defined $self->{'auths_to_link'} && defined $authid && !grep { $_ == $authid } @{ $self->{'auths_to_link'} } )
{
undef $authid;
}

19
C4/Linker/Default.pm
View File

@ -40,8 +40,7 @@ sub get_link {
$authid = $self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'authid'};
$fuzzy = $self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'fuzzy'};
$match_count = $self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'match_count'};
}
else {
} else {
# look for matching authorities
my $authorities = $heading->authorities(1); # $skipmetadata = true
@ -49,12 +48,10 @@ sub get_link {
if ( $behavior eq 'default' && $#{$authorities} == 0 ) {
$authid = $authorities->[0]->{'authid'};
}
elsif ( $behavior eq 'first' && $#{$authorities} >= 0 ) {
} elsif ( $behavior eq 'first' && $#{$authorities} >= 0 ) {
$authid = $authorities->[0]->{'authid'};
$fuzzy = $#{$authorities} > 0;
}
elsif ( $behavior eq 'last' && $#{$authorities} >= 0 ) {
} elsif ( $behavior eq 'last' && $#{$authorities} >= 0 ) {
$authid = $authorities->[ $#{$authorities} ]->{'authid'};
$fuzzy = $#{$authorities} > 0;
}
@ -64,16 +61,16 @@ sub get_link {
my @subfields = grep { $_->[0] ne '9' } $field->subfields();
if ( scalar @subfields > 1 ) {
pop @subfields;
$field =
MARC::Field->new(
$field = MARC::Field->new(
$field->tag,
$field->indicator(1),
$field->indicator(2),
map { $_->[0] => $_->[1] } @subfields
);
( $authid, $fuzzy ) =
$self->get_link( C4::Heading->new_from_field($field),
$behavior );
( $authid, $fuzzy ) = $self->get_link(
C4::Heading->new_from_field($field),
$behavior
);
}
}

122
C4/MarcModificationTemplates.pm
View File

@ -57,7 +57,6 @@ BEGIN {
);
}
=head1 NAME
C4::MarcModificationTemplates - Module to manage MARC Modification Templates
@ -243,7 +242,8 @@ sub AddModificationTemplateAction {
$conditional_regex ||= '0';
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare( 'SELECT MAX(ordering) + 1 AS next_ordering FROM marc_modification_template_actions WHERE template_id = ?' );
my $sth = $dbh->prepare(
'SELECT MAX(ordering) + 1 AS next_ordering FROM marc_modification_template_actions WHERE template_id = ?');
$sth->execute($template_id);
my $row = $sth->fetchrow_hashref;
my $ordering = $row->{'next_ordering'} || 1;
@ -386,7 +386,6 @@ sub ModModificationTemplateAction {
);
}
=head2
DelModificationTemplateAction
@ -404,7 +403,8 @@ sub DelModificationTemplateAction {
my $sth = $dbh->prepare("DELETE FROM marc_modification_template_actions WHERE mmta_id = ?");
$sth->execute($mmta_id);
$sth = $dbh->prepare("UPDATE marc_modification_template_actions SET ordering = ordering - 1 WHERE template_id = ? AND ordering > ?");
$sth = $dbh->prepare(
"UPDATE marc_modification_template_actions SET ordering = ordering - 1 WHERE template_id = ? AND ordering > ?");
$sth->execute( $action->{'template_id'}, $action->{'ordering'} );
}
@ -416,13 +416,16 @@ sub DelModificationTemplateAction {
Changes the order for the given action.
Options for $where are 'up', 'down', 'top' and 'bottom'
=cut
sub MoveModificationTemplateAction {
my ( $mmta_id, $where ) = @_;
my $action = GetModificationTemplateAction($mmta_id);
return if ( $action->{'ordering'} eq '1' && ( $where eq 'up' || $where eq 'top' ) );
return if ( $action->{'ordering'} eq GetModificationTemplateActions( $action->{'template_id'} ) && ( $where eq 'down' || $where eq 'bottom' ) );
return
if ( $action->{'ordering'} eq GetModificationTemplateActions( $action->{'template_id'} )
&& ( $where eq 'down' || $where eq 'bottom' ) );
my $dbh = C4::Context->dbh;
my ( $sth, $query );
@ -448,7 +451,9 @@ sub MoveModificationTemplateAction {
} elsif ( $where eq 'top' ) {
$sth = $dbh->prepare('UPDATE marc_modification_template_actions SET ordering = ordering + 1 WHERE template_id = ? AND ordering < ?');
$sth = $dbh->prepare(
'UPDATE marc_modification_template_actions SET ordering = ordering + 1 WHERE template_id = ? AND ordering < ?'
);
$sth->execute( $action->{'template_id'}, $action->{'ordering'} );
$sth = $dbh->prepare('UPDATE marc_modification_template_actions SET ordering = 1 WHERE mmta_id = ?');
@ -458,7 +463,9 @@ sub MoveModificationTemplateAction {
my $ordering = GetModificationTemplateActions( $action->{'template_id'} );
$sth = $dbh->prepare('UPDATE marc_modification_template_actions SET ordering = ordering - 1 WHERE template_id = ? AND ordering > ?');
$sth = $dbh->prepare(
'UPDATE marc_modification_template_actions SET ordering = ordering - 1 WHERE template_id = ? AND ordering > ?'
);
$sth->execute( $action->{'template_id'}, $action->{'ordering'} );
$sth = $dbh->prepare('UPDATE marc_modification_template_actions SET ordering = ? WHERE mmta_id = ?');
@ -529,45 +536,53 @@ sub ModifyRecordWithTemplate {
my $field_numbers = [];
if ($conditional) {
if ( $conditional_comparison eq 'exists' ) {
$field_numbers = field_exists({
$field_numbers = field_exists(
{
record => $record,
field => $conditional_field,
subfield => $conditional_subfield,
});
$do = $conditional eq 'if'
}
);
$do =
$conditional eq 'if'
? @$field_numbers
: not @$field_numbers;
}
elsif ( $conditional_comparison eq 'not_exists' ) {
$field_numbers = field_exists({
} elsif ( $conditional_comparison eq 'not_exists' ) {
$field_numbers = field_exists(
{
record => $record,
field => $conditional_field,
subfield => $conditional_subfield
});
$do = $conditional eq 'if'
}
);
$do =
$conditional eq 'if'
? not @$field_numbers
: @$field_numbers;
}
elsif ( $conditional_comparison eq 'equals' ) {
$field_numbers = field_equals({
} elsif ( $conditional_comparison eq 'equals' ) {
$field_numbers = field_equals(
{
record => $record,
value => $conditional_value,
field => $conditional_field,
subfield => $conditional_subfield,
is_regex => $conditional_regex,
});
$do = $conditional eq 'if'
}
);
$do =
$conditional eq 'if'
? @$field_numbers
: not @$field_numbers;
}
elsif ( $conditional_comparison eq 'not_equals' ) {
$field_numbers = field_equals({
} elsif ( $conditional_comparison eq 'not_equals' ) {
$field_numbers = field_equals(
{
record => $record,
value => $conditional_value,
field => $conditional_field,
subfield => $conditional_subfield,
is_regex => $conditional_regex,
});
}
);
my $all_fields = [
1 .. scalar @{
field_exists(
@ -581,11 +596,13 @@ sub ModifyRecordWithTemplate {
];
$field_numbers = [ Koha::MoreUtils::singleton( @$field_numbers, @$all_fields ) ];
if ( $from_field == $conditional_field ) {
$do = $conditional eq 'if'
$do =
$conditional eq 'if'
? @$field_numbers
: not @$field_numbers;
} else {
$do = $conditional eq 'if'
$do =
$conditional eq 'if'
? not @$field_numbers
: @$field_numbers;
}
@ -600,35 +617,44 @@ sub ModifyRecordWithTemplate {
# A condition has been given
if ( @$field_numbers > 0 ) {
if ( $field_number == 1 ) {
# We want only the first
if ( $from_field == $conditional_field ) {
# want first field matching condition
$field_numbers = [ $field_numbers->[0] ];
} else {
# condition doesn't match, so just want first occurrence of from field
$field_numbers = [1];
}
} else {
unless ( $from_field == $conditional_field ) {
# condition doesn't match from fields so need all occurrences of from fields for action
$field_numbers = field_exists({
$field_numbers = field_exists(
{
record => $record,
field => $from_field,
subfield => $from_subfield,
});
}
);
}
}
}
# There was no condition
else {
if ( $field_number == 1 ) {
# We want to process the first field
$field_numbers = [1];
}
}
if ( $action eq 'copy_field' ) {
copy_field({
copy_field(
{
record => $record,
from_field => $from_field,
from_subfield => $from_subfield,
@ -640,10 +666,11 @@ sub ModifyRecordWithTemplate {
modifiers => $to_regex_modifiers
},
field_numbers => $field_numbers,
});
}
elsif ( $action eq 'copy_and_replace_field' ) {
copy_and_replace_field({
);
} elsif ( $action eq 'copy_and_replace_field' ) {
copy_and_replace_field(
{
record => $record,
from_field => $from_field,
from_subfield => $from_subfield,
@ -655,28 +682,31 @@ sub ModifyRecordWithTemplate {
modifiers => $to_regex_modifiers
},
field_numbers => $field_numbers,
});
}
elsif ( $action eq 'add_field' ) {
add_field({
);
} elsif ( $action eq 'add_field' ) {
add_field(
{
record => $record,
field => $from_field,
subfield => $from_subfield,
values => [$field_value],
field_numbers => $field_numbers,
});
}
elsif ( $action eq 'update_field' ) {
update_field({
);
} elsif ( $action eq 'update_field' ) {
update_field(
{
record => $record,
field => $from_field,
subfield => $from_subfield,
values => [$field_value],
field_numbers => $field_numbers,
});
}
elsif ( $action eq 'move_field' ) {
move_field({
);
} elsif ( $action eq 'move_field' ) {
move_field(
{
record => $record,
from_field => $from_field,
from_subfield => $from_subfield,
@ -688,15 +718,17 @@ sub ModifyRecordWithTemplate {
modifiers => $to_regex_modifiers
},
field_numbers => $field_numbers,
});
}
elsif ( $action eq 'delete_field' ) {
delete_field({
);
} elsif ( $action eq 'delete_field' ) {
delete_field(
{
record => $record,
field => $from_field,
subfield => $from_subfield,
field_numbers => $field_numbers,
});
}
);
}
}
}

156
C4/Matcher.pm
View File

@ -19,7 +19,6 @@ package C4::Matcher;
use Modern::Perl;
use Koha::SearchEngine;
use Koha::SearchEngine::Search;
use Koha::SearchEngine::QueryBuilder;
@ -228,10 +227,13 @@ sub _fetch_matchpoint {
$component->{'offset'} = int( $row->{'offset'} );
$component->{'length'} = int( $row->{'length'} );
$component->{'norms'} = [];
my $sth2 = $dbh->prepare_cached("SELECT *
my $sth2 = $dbh->prepare_cached(
"SELECT *
FROM matchpoint_component_norms
WHERE matchpoint_component_id = ? ORDER BY sequence");
WHERE matchpoint_component_id = ? ORDER BY sequence"
);
$sth2->execute( $row->{'matchpoint_component_id'} );
while ( my $row2 = $sth2->fetchrow_hashref ) {
push @{ $component->{'norms'} }, $row2->{'norm_routine'};
}
@ -256,10 +258,12 @@ sub store {
my $self = shift;
if ( defined $self->{'id'} ) {
# update
$self->_del_matcher_components();
$self->_update_marc_matchers();
} else {
# create new
$self->_new_marc_matchers();
}
@ -275,6 +279,7 @@ sub _del_matcher_components {
$sth->execute( $self->{'id'} );
$sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
$sth->execute( $self->{'id'} );
# foreign key delete cascades take care of deleting relevant rows
# from matcher_matchpoints, matchpoint_components, and
# matchpoint_component_norms
@ -284,22 +289,29 @@ sub _update_marc_matchers {
my $self = shift;
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare_cached("UPDATE marc_matchers
my $sth = $dbh->prepare_cached(
"UPDATE marc_matchers
SET code = ?,
description = ?,
record_type = ?,
threshold = ?
WHERE matcher_id = ?");
$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'}, $self->{'id'});
WHERE matcher_id = ?"
);
$sth->execute(
$self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'},
$self->{'id'}
);
}
sub _new_marc_matchers {
my $self = shift;
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare_cached("INSERT INTO marc_matchers
my $sth = $dbh->prepare_cached(
"INSERT INTO marc_matchers
(code, description, record_type, threshold)
VALUES (?, ?, ?, ?)");
VALUES (?, ?, ?, ?)"
);
$sth->execute( $self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'} );
$self->{'id'} = $dbh->{'mysql_insertid'};
}
@ -312,16 +324,20 @@ sub _store_matcher_components {
my $matcher_id = $self->{'id'};
foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
my $matchpoint_id = $self->_store_matchpoint($matchpoint);
$sth = $dbh->prepare_cached("INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
VALUES (?, ?)");
$sth = $dbh->prepare_cached(
"INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
VALUES (?, ?)"
);
$sth->execute( $matcher_id, $matchpoint_id );
}
foreach my $matchcheck ( @{ $self->{'required_checks'} } ) {
my $source_matchpoint_id = $self->_store_matchpoint( $matchcheck->{'source_matchpoint'} );
my $target_matchpoint_id = $self->_store_matchpoint( $matchcheck->{'target_matchpoint'} );
$sth = $dbh->prepare_cached("INSERT INTO matchchecks
$sth = $dbh->prepare_cached(
"INSERT INTO matchchecks
(matcher_id, source_matchpoint_id, target_matchpoint_id)
VALUES (?, ?, ?)");
VALUES (?, ?, ?)"
);
$sth->execute( $matcher_id, $source_matchpoint_id, $target_matchpoint_id );
}
@ -334,16 +350,21 @@ sub _store_matchpoint {
my $dbh = C4::Context->dbh();
my $sth;
my $matcher_id = $self->{'id'};
$sth = $dbh->prepare_cached("INSERT INTO matchpoints (matcher_id, search_index, score)
VALUES (?, ?, ?)");
$sth = $dbh->prepare_cached(
"INSERT INTO matchpoints (matcher_id, search_index, score)
VALUES (?, ?, ?)"
);
$sth->execute( $matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'} || 0 );
my $matchpoint_id = $dbh->{'mysql_insertid'};
my $seqnum = 0;
foreach my $component ( @{ $matchpoint->{'components'} } ) {
$seqnum++;
$sth = $dbh->prepare_cached("INSERT INTO matchpoint_components
$sth = $dbh->prepare_cached(
"INSERT INTO matchpoint_components
(matchpoint_id, sequence, tag, subfields, `offset`, length)
VALUES (?, ?, ?, ?, ?, ?)");
VALUES (?, ?, ?, ?, ?, ?)"
);
$sth->bind_param( 1, $matchpoint_id );
$sth->bind_param( 2, $seqnum );
$sth->bind_param( 3, $component->{'tag'} );
@ -353,18 +374,20 @@ sub _store_matchpoint {
$sth->execute();
my $matchpoint_component_id = $dbh->{'mysql_insertid'};
my $normseq = 0;
foreach my $norm ( @{ $component->{'norms'} } ) {
$normseq++;
$sth = $dbh->prepare_cached("INSERT INTO matchpoint_component_norms
$sth = $dbh->prepare_cached(
"INSERT INTO matchpoint_component_norms
(matchpoint_component_id, sequence, norm_routine)
VALUES (?, ?, ?)");
VALUES (?, ?, ?)"
);
$sth->execute( $matchpoint_component_id, $normseq, $norm );
}
}
return $matchpoint_id;
}
=head2 delete
C4::Matcher->delete($id);
@ -510,12 +533,16 @@ sub add_simple_matchpoint {
my $self = shift;
my ( $index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer ) = @_;
$self->add_matchpoint($index, $score, [
{ tag => $source_tag, subfields => $source_subfields,
$self->add_matchpoint(
$index, $score,
[
{
tag => $source_tag, subfields => $source_subfields,
offset => $source_offset, 'length' => $source_length,
norms => [$source_normalizer]
}
]);
]
);
}
=head2 add_required_check
@ -584,14 +611,26 @@ must match for a match to be considered valid.
sub add_simple_required_check {
my $self = shift;
my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
$target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;
my (
$source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
$target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer
) = @_;
$self->add_required_check(
[ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, 'length' => $source_length,
norms => [ $source_normalizer ] } ],
[ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, 'length' => $target_length,
norms => [ $target_normalizer ] } ]
[
{
tag => $source_tag, subfields => $source_subfields, offset => $source_offset,
'length' => $source_length,
norms => [$source_normalizer]
}
],
[
{
tag => $target_tag, subfields => $target_subfields, offset => $target_offset,
'length' => $target_length,
norms => [$target_normalizer]
}
]
);
}
@ -647,9 +686,15 @@ sub get_matches {
my $total_hits;
if ( $self->{'record_type'} eq 'biblio' ) {
my $phr = ( C4::Context->preference('AggressiveMatchOnISBN') || C4::Context->preference('AggressiveMatchOnISSN') ) ? ',phr' : q{};
$query = join( " OR ",
map { "$matchpoint->{'index'}$phr=\"$_\"" } @source_keys );
my $phr =
( C4::Context->preference('AggressiveMatchOnISBN') || C4::Context->preference('AggressiveMatchOnISSN') )
? ',phr'
: q{};
$query = join(
" OR ",
map { "$matchpoint->{'index'}$phr=\"$_\"" } @source_keys
);
#NOTE: double-quote the values so you don't get a "Embedded truncation not supported" error when a term has a ? in it.
# Use state variables to avoid recreating the objects every time.
@ -661,21 +706,21 @@ sub get_matches {
if ( defined $error ) {
warn "search failed ($query) $error";
}
else {
} else {
foreach my $matched ( @{$searchresults} ) {
my $target_record = C4::Search::new_record_from_zebra( 'biblioserver', $matched );
my ( $biblionumber_tag, $biblionumber_subfield ) = C4::Biblio::GetMarcFromKohaField( "biblio.biblionumber" );
my $id = ( $biblionumber_tag > 10 ) ?
$target_record->field($biblionumber_tag)->subfield($biblionumber_subfield) :
$target_record->field($biblionumber_tag)->data();
my ( $biblionumber_tag, $biblionumber_subfield ) =
C4::Biblio::GetMarcFromKohaField("biblio.biblionumber");
my $id =
( $biblionumber_tag > 10 )
? $target_record->field($biblionumber_tag)->subfield($biblionumber_subfield)
: $target_record->field($biblionumber_tag)->data();
$matches->{$id}->{score} += $matchpoint->{score};
$matches->{$id}->{record} = $target_record;
}
}
}
elsif ( $self->{'record_type'} eq 'authority' ) {
} elsif ( $self->{'record_type'} eq 'authority' ) {
my @marclist;
my @and_or;
my @excluding = [];
@ -687,10 +732,12 @@ sub get_matches {
push @operator, 'exact';
push @value, $key;
}
# Use state variables to avoid recreating the objects every time.
# With Elasticsearch this also avoids creating a massive amount of
# ES connectors that would eventually run out of file descriptors.
state $builder = Koha::SearchEngine::QueryBuilder->new({index => $Koha::SearchEngine::AUTHORITIES_INDEX});
state $builder =
Koha::SearchEngine::QueryBuilder->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
state $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
my $search_query = $builder->build_authorities_query_compat(
\@marclist, \@and_or, \@excluding, \@operator,
@ -708,11 +755,13 @@ sub get_matches {
}
# get rid of any that don't meet the threshold
$matches = { map { ($matches->{$_}->{score} >= $self->{'threshold'}) ? ($_ => $matches->{$_}) : () } keys %$matches };
$matches =
{ map { ( $matches->{$_}->{score} >= $self->{'threshold'} ) ? ( $_ => $matches->{$_} ) : () } keys %$matches };
my @results = ();
if ( $self->{'record_type'} eq 'biblio' ) {
require C4::Biblio;
# get rid of any that don't meet the required checks
$matches = {
map {
@ -730,6 +779,7 @@ sub get_matches {
}
} elsif ( $self->{'record_type'} eq 'authority' ) {
require C4::AuthoritiesMarc;
# get rid of any that don't meet the required checks
$matches = {
map {
@ -746,10 +796,7 @@ sub get_matches {
};
}
}
@results = sort {
$b->{'score'} cmp $a->{'score'} or
$b->{'record_id'} cmp $a->{'record_id'}
} @results;
@results = sort { $b->{'score'} cmp $a->{'score'} or $b->{'record_id'} cmp $a->{'record_id'} } @results;
if ( scalar(@results) > $max_matches ) {
@results = @results[ 0 .. $max_matches - 1 ];
}
@ -832,8 +879,7 @@ sub _get_match_keys {
my $tag = $component->{'tag'};
if ( $tag && $tag eq 'LDR' ) {
$fields[0] = $source_record->leader();
}
else {
} else {
@fields = $source_record->field($tag);
}
@ -845,8 +891,7 @@ sub _get_match_keys {
my $string;
if ( !ref $field ) {
$string = "$field";
}
elsif ( $field->is_control_field() ) {
} elsif ( $field->is_control_field() ) {
$string = $field->data();
} elsif ( defined $component->{subfields} && keys %{ $component->{subfields} } ) {
$string = $field->as_string(
@ -869,17 +914,13 @@ sub _get_match_keys {
if ( grep { $norm eq $_ } valid_normalization_routines() ) {
if ( $norm eq 'remove_spaces' ) {
$key = remove_spaces($key);
}
elsif ( $norm eq 'upper_case' ) {
} elsif ( $norm eq 'upper_case' ) {
$key = upper_case($key);
}
elsif ( $norm eq 'lower_case' ) {
} elsif ( $norm eq 'lower_case' ) {
$key = lower_case($key);
}
elsif ( $norm eq 'legacy_default' ) {
} elsif ( $norm eq 'legacy_default' ) {
$key = legacy_default($key);
}
elsif ( $norm eq 'ISBN' ) {
} elsif ( $norm eq 'ISBN' ) {
$key = ISBN($key);
}
} else {
@ -898,7 +939,6 @@ sub _get_match_keys {
return @keys;
}
sub _parse_match_component {
my $input_component = shift;

40
C4/Members.pm
View File

@ -19,7 +19,6 @@ package C4::Members;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Context;
use Scalar::Util qw( looks_like_number );
@ -38,6 +37,7 @@ use Koha::Patrons;
use Koha::Patron::Categories;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -142,8 +142,7 @@ sub patronflags {
$flaginfo{'noissues'} = 1;
}
$flags{'CHARGES'} = \%flaginfo;
}
elsif ( ( my $balance = $account->balance ) < 0 ) {
} elsif ( ( my $balance = $account->balance ) < 0 ) {
my %flaginfo;
$flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
$flaginfo{'amount'} = sprintf "%.02f", $balance;
@ -156,7 +155,8 @@ sub patronflags {
if ( defined $no_issues_charge_guarantees ) {
if ( $patron_charge_limits->{NoIssuesChargeGuarantees}->{overlimit} ) {
my %flaginfo;
$flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $patron_charge_limits->{NoIssuesChargeGuarantees}->{charge};
$flaginfo{'message'} = sprintf 'patron guarantees owe %.02f',
$patron_charge_limits->{NoIssuesChargeGuarantees}->{charge};
$flaginfo{'amount'} = $patron_charge_limits->{NoIssuesChargeGuarantees}->{charge};
$flaginfo{'noissues'} = 1 unless C4::Context->preference("allowfineoverride");
$flags{'CHARGES_GUARANTEES'} = \%flaginfo;
@ -199,11 +199,8 @@ sub patronflags {
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"; # newline is display layer
foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} } @$itemsoverdue ) {
$flaginfo{'itemlisttext'} .= "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
}
$flags{'ODUES'} = \%flaginfo;
}
@ -240,13 +237,17 @@ sub GetBorrowersToExpunge {
my $filterexpiry = $params->{'expired_before'};
my $filterlastseen = $params->{'last_seen'};
my $filtercategory = $params->{'category_code'};
my $filterbranch = $params->{'branchcode'} ||
((C4::Context->preference('IndependentBranches')
my $filterbranch = $params->{'branchcode'}
|| (
(
C4::Context->preference('IndependentBranches')
&& C4::Context->userenv
&& !C4::Context->IsSuperLibrarian()
&& C4::Context->userenv->{branch})
&& C4::Context->userenv->{branch}
)
? C4::Context->userenv->{branch}
: "");
: ""
);
my $filterpatronlist = $params->{'patron_list_id'};
my $dbh = C4::Context->dbh;
@ -316,8 +317,7 @@ sub GetBorrowersToExpunge {
my $sth = $dbh->prepare($query);
if ( scalar(@query_params) > 0 ) {
$sth->execute(@query_params);
}
else {
} else {
$sth->execute;
}
@ -403,8 +403,7 @@ sub IssueSlip {
'>=' => $today_start,
'<=' => $today_end,
},
lastreneweddate =>
{ '>=' => $today_start, '<=' => $today_end, }
lastreneweddate => { '>=' => $today_start, '<=' => $today_end, }
}
}
);
@ -425,12 +424,13 @@ sub IssueSlip {
%loops = (
issues => [ map { $_->{issues}{itemnumber} } @checkouts ], # TT syntax
);
}
else {
} else {
my $today = Koha::Database->new->schema->storage->datetime_parser->format_datetime(dt_from_string);
# Checkouts due in the future
my $checkouts = $pending_checkouts->search( { date_due => { '>' => $today } } );
my @checkouts; my @overdues;
my @checkouts;
my @overdues;
while ( my $c = $checkouts->next ) {
my $all = $c->unblessed_all_relateds;
push @checkouts, {

19
C4/Members/Messaging.pm
View File

@ -21,8 +21,6 @@ use strict;
use warnings;
use C4::Context;
=head1 NAME
C4::Members::Messaging - manage patron messaging preferences
@ -160,14 +158,18 @@ VALUES
END_SQL
$sth = C4::Context->dbh()->prepare($insert_bmp);
# set up so that we can easily construct the insert SQL
$params->{'borrowernumber'} = undef unless exists( $params->{'borrowernumber'} );
$params->{'categorycode'} = undef unless exists( $params->{'categorycode'} );
my $success = $sth->execute( $params->{'borrowernumber'},
my $success = $sth->execute(
$params->{'borrowernumber'},
$params->{'categorycode'},
$params->{'message_attribute_id'},
$params->{'days_in_advance'},
$params->{'wants_digest'} );
$params->{'wants_digest'}
);
# my $borrower_message_preference_id = $dbh->last_insert_id();
my $borrower_message_preference_id = $dbh->{'mysql_insertid'};
@ -264,8 +266,13 @@ sub SetMessagingPreferencesFromDefaults {
if ( defined $params->{message_name} && $option->{'message_name'} ne $params->{message_name} ) {
next OPTION;
}
my $default_pref = GetMessagingPreferences( { categorycode => $params->{categorycode},
message_name => $option->{'message_name'} } );
my $default_pref = GetMessagingPreferences(
{
categorycode => $params->{categorycode},
message_name => $option->{'message_name'}
}
);
# FIXME - except for setting the borrowernumber, it really ought to be possible
# to have the output of GetMessagingPreferences be able to be the input
# to SetMessagingPreference

3
C4/Members/Statistics.pm
View File

@ -119,7 +119,8 @@ sub GetTotalIssuesReturnedTodayByBorrower {
my ($borrowernumber) = @_;
my $dbh = C4::Context->dbh;
my $query = construct_query "total_issues_returned_today", "FROM old_issues i, items it WHERE i.itemnumber = it.itemnumber AND i.borrowernumber = ? AND DATE(i.returndate) = CAST(now() AS date) ";
my $query = construct_query "total_issues_returned_today",
"FROM old_issues i, items it WHERE i.itemnumber = it.itemnumber AND i.borrowernumber = ? AND DATE(i.returndate) = CAST(now() AS date) ";
my $sth = $dbh->prepare($query);
$sth->execute($borrowernumber);

17
C4/Message.pm
View File

@ -18,7 +18,6 @@ package C4::Message;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use strict;
use warnings;
use C4::Context;
@ -68,10 +67,8 @@ database.
=cut
our $AUTOLOAD;
=head2 Class Methods
=head3 C4::Message->new(\%attributes)
@ -87,7 +84,6 @@ sub new {
bless {%$opts} => $class;
}
=head3 C4::Message->find($id)
This method searches the message_queue table for a row with the given
@ -123,6 +119,7 @@ message before it gets sent out.)
# -- get the borrower's most recent pending checkin or checkout notification
sub find_last_message {
my ( $class, $borrower, $letter_code, $transport ) = @_;
# $type is the message_transport_type
$transport ||= 'email';
my $dbh = C4::Context->dbh;
@ -147,7 +144,6 @@ sub find_last_message {
}
}
=head3 C4::Message->enqueue($letter, $patron, $transport)
This is a front-end for C<C4::Letters::EnqueueLetter()> that adds metadata to
@ -183,18 +179,13 @@ sub _to_address {
my $address;
if ( $transport eq 'email' ) {
$address = $patron->notice_email_address;
}
elsif ( $transport eq 'sms' ) {
} elsif ( $transport eq 'sms' ) {
$address = $patron->smsalertnumber;
}
else {
} else {
warn "'$transport' is an unknown message transport.";
}
if ( not defined $address ) {
warn "An appropriate $transport address "
. "for borrower "
. $patron->userid
. "could not be found.";
warn "An appropriate $transport address " . "for borrower " . $patron->userid . "could not be found.";
}
return $address;
}

12
C4/OAI/Sets.pm
View File

@ -426,7 +426,10 @@ sub ModOAISetMappings {
};
$sth = $dbh->prepare($query);
foreach (@$mappings) {
$sth->execute($set_id, $_->{'marcfield'}, $_->{'marcsubfield'}, $_->{'operator'}, $_->{'marcvalue'}, $_->{'rule_operator'}, $_->{'rule_order'});
$sth->execute(
$set_id, $_->{'marcfield'}, $_->{'marcsubfield'}, $_->{'operator'}, $_->{'marcvalue'},
$_->{'rule_operator'}, $_->{'rule_order'}
);
}
}
}
@ -544,10 +547,13 @@ sub _evalRule {
my $value = $mapping->{'marcvalue'};
my @all_subfield_values;
# Get all the fields with the given tag
my @fields = $record->field($field);
# Iterate over all the fields
foreach my $field (@fields) {
# Get the values from all the subfields with the given subfield code
if ( my @subfield_values = $field->subfield($subfield) ) {
push @all_subfield_values, @subfield_values;
@ -558,8 +564,7 @@ sub _evalRule {
if ( 0 == grep { $_ eq $value } @all_subfield_values ) {
return 1;
}
}
else {
} else {
if ( 0 < grep { $_ eq $value } @all_subfield_values ) {
return 1;
}
@ -567,7 +572,6 @@ sub _evalRule {
return 0;
}
=head2 ModOAISetsBiblios
my $oai_sets_biblios = {

84
C4/Output.pm
View File

@ -21,7 +21,6 @@ package C4::Output;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
# NOTE: I'm pretty sure this module is deprecated in favor of
# templates.
@ -114,17 +113,9 @@ sub pagination_bar {
# link to first page?
if ( $current_page > 1 ) {
$pagination_bar .=
"\n" . '&nbsp;'
. '<a href="'
. $url
. '1'
. $url_suffix
. '"rel="start">'
. '&lt;&lt;' . '</a>';
}
else {
$pagination_bar .=
"\n" . '&nbsp;<span class="inactive">&lt;&lt;</span>';
"\n" . '&nbsp;' . '<a href="' . $url . '1' . $url_suffix . '"rel="start">' . '&lt;&lt;' . '</a>';
} else {
$pagination_bar .= "\n" . '&nbsp;<span class="inactive">&lt;&lt;</span>';
}
# link on previous page ?
@ -132,16 +123,9 @@ sub pagination_bar {
my $previous = $current_page - 1;
$pagination_bar .=
"\n" . '&nbsp;'
. '<a href="'
. $url
. $previous
. $url_suffix
. '" rel="prev">' . '&lt;' . '</a>';
}
else {
$pagination_bar .=
"\n" . '&nbsp;<span class="inactive">&lt;</span>';
"\n" . '&nbsp;' . '<a href="' . $url . $previous . $url_suffix . '" rel="prev">' . '&lt;' . '</a>';
} else {
$pagination_bar .= "\n" . '&nbsp;<span class="inactive">&lt;</span>';
}
my $min_to_display = $current_page - $pages_around;
@ -159,25 +143,19 @@ sub pagination_bar {
if ( defined $last_displayed_page
and $last_displayed_page != $page_number - 1 )
{
$pagination_bar .=
"\n" . '&nbsp;<span class="inactive">...</span>';
$pagination_bar .= "\n" . '&nbsp;<span class="inactive">...</span>';
}
if ( $page_number == $current_page ) {
$pagination_bar .= "\n" . '&nbsp;' . '<span class="currentPage">' . $page_number . '</span>';
} else {
$pagination_bar .=
"\n" . '&nbsp;'
. '<span class="currentPage">'
. $page_number
. '</span>';
}
else {
$pagination_bar .=
"\n" . '&nbsp;'
"\n"
. '&nbsp;'
. '<a href="'
. $url
. $page_number
. $url_suffix
. '">'
. $url_suffix . '">'
. $page_number . '</a>';
}
$last_displayed_page = $page_number;
@ -188,31 +166,18 @@ sub pagination_bar {
if ( $current_page < $nb_pages ) {
my $next = $current_page + 1;
$pagination_bar .= "\n"
. '&nbsp;<a href="'
. $url
. $next
. $url_suffix
. '" rel="next">' . '&gt;' . '</a>';
}
else {
$pagination_bar .=
"\n" . '&nbsp;<span class="inactive">&gt;</span>';
"\n" . '&nbsp;<a href="' . $url . $next . $url_suffix . '" rel="next">' . '&gt;' . '</a>';
} else {
$pagination_bar .= "\n" . '&nbsp;<span class="inactive">&gt;</span>';
}
# link to last page?
if ( $current_page != $nb_pages ) {
$pagination_bar .= "\n"
. '&nbsp;<a href="'
. $url
. $nb_pages
. $url_suffix
. '" rel="last">'
. '&gt;&gt;' . '</a>';
}
else {
$pagination_bar .=
"\n" . '&nbsp;<span class="inactive">&gt;&gt;</span>';
"\n" . '&nbsp;<a href="' . $url . $nb_pages . $url_suffix . '" rel="last">' . '&gt;&gt;' . '</a>';
} else {
$pagination_bar .= "\n" . '&nbsp;<span class="inactive">&gt;&gt;</span>';
}
}
@ -250,6 +215,7 @@ sub output_with_http_headers {
'js' => 'text/javascript',
'json' => 'application/json',
'xml' => 'text/xml',
# NOTE: not using application/atom+xml or application/rss+xml because of
# Internet Explorer 6; see bug 2078.
'rss' => 'text/xml',
@ -290,7 +256,6 @@ sub output_html_with_http_headers {
output_with_http_headers( $query, $cookie, $data, 'html', $status, $extra_options );
}
sub output_ajax_with_http_headers {
my ( $query, $js ) = @_;
print $query->header(
@ -339,19 +304,16 @@ sub output_and_exit_if_error {
my $current_patron = $params->{current_patron};
if ( not $current_patron ) {
$error = 'unknown_patron';
}
elsif ( not $logged_in_user->can_see_patron_infos($current_patron) )
{
} elsif ( not $logged_in_user->can_see_patron_infos($current_patron) ) {
$error = 'cannot_see_patron_infos';
}
}
elsif ( $params->{module} eq 'cataloguing' ) {
} elsif ( $params->{module} eq 'cataloguing' ) {
# We are testing the record to avoid additem to fetch the Koha::Biblio
# But in the long term we will want to get a biblio in parameter
$error = 'unknown_biblio' unless $params->{record};
}
}
elsif ( $params and exists $params->{check} ) {
} elsif ( $params and exists $params->{check} ) {
if ( $params->{check} eq 'csrf_token' ) {
$error = 'wrong_csrf_token'
unless Koha::Token->new->check_csrf(

77
C4/Overdues.pm
View File

@ -1,6 +1,5 @@
package C4::Overdues;
# Copyright 2000-2002 Katipo Communications
# copyright 2010 BibLibre
#
@ -38,6 +37,7 @@ use Koha::Logger;
use Koha::Patrons;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -124,7 +124,6 @@ LEFT JOIN biblioitems USING (biblioitemnumber)
return $sth->fetchall_arrayref( {} );
}
=head2 checkoverdues
($count, $overdueitems) = checkoverdues($borrowernumber);
@ -224,6 +223,7 @@ sub CalcFine {
return ( 0, 0, 0 ) unless ( DateTime->compare( $due_dt, $end_date ) == -1 );
my $start_date = $due_dt->clone();
# get issuingrules (fines part will be used)
my $itemtype = $item->{itemtype} || $item->{itype};
my $issuing_rule = Koha::CirculationRules->get_effective_rules(
@ -256,9 +256,11 @@ sub CalcFine {
if ( $issuing_rule->{chargeperiod} && ( $units_minus_grace > 0 ) ) {
my $units = C4::Context->preference('FinesIncludeGracePeriod') ? $chargeable_units : $units_minus_grace;
my $charge_periods = $units / $issuing_rule->{chargeperiod};
# If chargeperiod_charge_at = 1, we charge a fine at the start of each charge period
# if chargeperiod_charge_at = 0, we charge at the end of each charge period
$charge_periods = defined $issuing_rule->{chargeperiod_charge_at} && $issuing_rule->{chargeperiod_charge_at} == 1 ? ceil($charge_periods) : floor($charge_periods);
$charge_periods = defined $issuing_rule->{chargeperiod_charge_at}
&& $issuing_rule->{chargeperiod_charge_at} == 1 ? ceil($charge_periods) : floor($charge_periods);
# check if item has been recalled. recall should have been marked Overdue by cronjob, so only look at overdue recalls
# only charge using recall_overdue_fine if there is an item-level recall for this particular item, OR a biblio-level recall
@ -266,17 +268,22 @@ sub CalcFine {
my $bib_level_recall = 0;
$bib_level_recall = 1 if scalar @recalls > 0;
foreach my $recall (@recalls) {
if ( $recall->item_level and $recall->item_id == $item->{itemnumber} and $issuing_rule->{recall_overdue_fine} ) {
if ( $recall->item_level
and $recall->item_id == $item->{itemnumber}
and $issuing_rule->{recall_overdue_fine} )
{
$bib_level_recall = 0;
$amount = $charge_periods * $issuing_rule->{recall_overdue_fine};
last;
}
}
if ( $bib_level_recall and $issuing_rule->{recall_overdue_fine} ) {
# biblio-level recall
$amount = $charge_periods * $issuing_rule->{recall_overdue_fine};
}
if ( scalar @recalls == 0 && $issuing_rule->{fine} ) {
# no recall, use normal fine amount
$amount = $charge_periods * $issuing_rule->{fine};
}
@ -295,12 +302,14 @@ sub CalcFine {
$item->{replacementprice} = $itemtype->defaultreplacecost;
}
$amount = $item->{replacementprice} if ( $issuing_rule->{cap_fine_to_replacement_price} && $item->{replacementprice} && $amount > $item->{replacementprice} );
$amount = $item->{replacementprice}
if ( $issuing_rule->{cap_fine_to_replacement_price}
&& $item->{replacementprice}
&& $amount > $item->{replacementprice} );
return ( $amount, $units_minus_grace, $chargeable_units );
}
=head2 get_chargeable_units
get_chargeable_units($unit, $start_date_ $end_date, $branchcode);
@ -334,8 +343,7 @@ sub get_chargeable_units {
return 1;
}
return $charge_duration->in_units('hours');
}
else { # days
} else { # days
if ( C4::Context->preference('finesCalendar') eq 'noFinesWhenClosed' ) {
my $calendar = Koha::Calendar->new( branchcode => $branchcode );
$charge_duration = $calendar->days_between( $date_due, $date_returned );
@ -346,7 +354,6 @@ sub get_chargeable_units {
}
}
=head2 GetSpecialHolidays
&GetSpecialHolidays($date_dues,$itemnumber);
@ -370,8 +377,7 @@ sub GetSpecialHolidays {
# use sql request to find all date between date_due and today
my $dbh = C4::Context->dbh;
my $query =
qq|SELECT DATE_FORMAT(concat(year,'-',month,'-',day),'%Y-%m-%d') as date
my $query = qq|SELECT DATE_FORMAT(concat(year,'-',month,'-',day),'%Y-%m-%d') as date
FROM `special_holidays`
WHERE DATE_FORMAT(concat(year,'-',month,'-',day),'%Y-%m-%d') >= ?
AND DATE_FORMAT(concat(year,'-',month,'-',day),'%Y-%m-%d') <= ?
@ -393,8 +399,7 @@ AND branchcode=?
for ( my $i = 0 ; $i < scalar(@result_date) ; $i++ ) {
$dateinsec = UnixDate( $result_date[$i]->{'date'}, "%o" );
( undef, undef, undef, undef, undef, undef, $wday, undef, undef ) =
localtime($dateinsec);
( undef, undef, undef, undef, undef, undef, $wday, undef, undef ) = localtime($dateinsec);
for ( my $j = 0 ; $j < scalar(@result) ; $j++ ) {
if ( $wday == ( $result[$j]->{'weekday'} ) ) {
$specialdaycount--;
@ -422,8 +427,7 @@ C<$difference> numbers of between day date of the day and date due
sub GetRepeatableHolidays {
my ( $date_dues, $itemnumber, $difference ) = @_;
my $dateinsec = UnixDate( $date_dues, "%o" );
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
localtime($dateinsec);
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($dateinsec);
my @result = GetWdayFromItemnumber($itemnumber);
my @dayclosedcount;
my $j;
@ -442,7 +446,6 @@ sub GetRepeatableHolidays {
return scalar(@dayclosedcount);
}
=head2 GetWayFromItemnumber
&Getwdayfromitemnumber($itemnumber);
@ -470,7 +473,6 @@ sub GetWdayFromItemnumber {
return @result;
}
=head2 GetIssuesIteminfo
&GetIssuesIteminfo($itemnumber);
@ -494,7 +496,6 @@ sub GetIssuesIteminfo {
return $issuesinfo;
}
=head2 UpdateFine
&UpdateFine(
@ -558,17 +559,21 @@ sub UpdateFine {
my $accountline;
my $total_amount_other = 0.00;
# Cycle through the fines and
# - find line that relates to the requested $itemnum
# - accumulate fines for other items
# so we can update $itemnum fine taking in account fine caps
while ( my $overdue = $overdues->next ) {
if ( defined $overdue->checkout && $overdue->checkout->issue_id == $issue_id && $overdue->status eq 'UNRETURNED' ) {
if ( defined $overdue->checkout
&& $overdue->checkout->issue_id == $issue_id
&& $overdue->status eq 'UNRETURNED' )
{
if ($accountline) {
Koha::Logger->get->debug("Not a unique accountlines record for issue_id $issue_id"); # FIXME Do we really need to log that?
Koha::Logger->get->debug("Not a unique accountlines record for issue_id $issue_id")
; # FIXME Do we really need to log that?
#FIXME Should we still count this one in total_amount ??
}
else {
} else {
$accountline = $overdue;
}
}
@ -581,12 +586,15 @@ sub UpdateFine {
if ($accountline) {
if ( ( $amount - $accountline->amount ) > $maxIncrease ) {
my $new_amount = $accountline->amount + $maxIncrease;
Koha::Logger->get->debug("Reducing fine for item $itemnum borrower $borrowernumber from $amount to $new_amount - MaxFine reached");
Koha::Logger->get->debug(
"Reducing fine for item $itemnum borrower $borrowernumber from $amount to $new_amount - MaxFine reached"
);
$amount = $new_amount;
}
}
elsif ( $amount > $maxIncrease ) {
Koha::Logger->get->debug("Reducing fine for item $itemnum borrower $borrowernumber from $amount to $maxIncrease - MaxFine reached");
} elsif ( $amount > $maxIncrease ) {
Koha::Logger->get->debug(
"Reducing fine for item $itemnum borrower $borrowernumber from $amount to $maxIncrease - MaxFine reached"
);
$amount = $maxIncrease;
}
}
@ -604,7 +612,8 @@ sub UpdateFine {
} else {
if ($amount) { # Don't add new fines with an amount of 0
my $patron = Koha::Patrons->find($borrowernumber);
my $letter = eval { C4::Letters::GetPreparedLetter(
my $letter = eval {
C4::Letters::GetPreparedLetter(
module => 'circulation',
letter_code => 'OVERDUE_FINE_DESC',
message_transport_type => 'print',
@ -614,7 +623,8 @@ sub UpdateFine {
borrowers => $borrowernumber,
items => $itemnum,
},
) };
);
};
my $desc = $letter ? $letter->{content} : sprintf( "Item %s - due %s", $itemnum, output_pref($due) );
my $account = Koha::Account->new( { patron_id => $borrowernumber } );
@ -655,8 +665,7 @@ sub GetFine {
AND amountoutstanding > 0 AND borrowernumber=?|;
my @query_param;
push @query_param, $borrowernumber;
if (defined $itemnum )
{
if ( defined $itemnum ) {
$query .= " AND itemnumber=?";
push @query_param, $itemnum;
}
@ -679,13 +688,16 @@ returns a list of branch codes for branches with overdue rules defined.
sub GetBranchcodesWithOverdueRules {
my $dbh = C4::Context->dbh;
my $branchcodes = $dbh->selectcol_arrayref(q|
my $branchcodes = $dbh->selectcol_arrayref(
q|
SELECT DISTINCT(branchcode)
FROM overduerules
WHERE delay1 IS NOT NULL
ORDER BY branchcode
|);
|
);
if ( defined $branchcodes->[0] && $branchcodes->[0] eq '' ) {
# If a default rule exists, all branches should be returned
return Koha::Libraries->search( {}, { order_by => 'branchname' } )->get_column('branchcode');
}
@ -830,6 +842,7 @@ sub parse_overdues_letter {
foreach my $item (@$i) {
my $fine = GetFine( $item->{'itemnumber'}, $params->{'borrowernumber'} );
$item->{'fine'} = currency_format( $currency_format, "$fine", FMT_SYMBOL );
# if active currency isn't correct ISO code fallback to sprintf
$item->{'fine'} = sprintf( '%.2f', $fine ) unless $item->{'fine'};

4
C4/Patroncards/Batch.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Batch);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

4
C4/Patroncards/Layout.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Layout);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

26
C4/Patroncards/Lib.pm
View File

@ -52,26 +52,24 @@ sub text_alignment {
grep { $space_count++ if $_ eq '20' } @$UTF82HEX;
$Tw = ( ( $text_box_width - $text_llx ) - $string_width ) / $space_count;
return $origin_llx, $Tw;
}
elsif ($alignment eq 'C') {
} elsif ( $alignment eq 'C' ) {
my $center_margin = ( $text_box_width / 2 ) + ( $origin_llx - $text_llx );
$Tx = $center_margin - ( $string_width / 2 );
return $Tx, $Tw;
}
elsif ($alignment eq 'R') {
} elsif ( $alignment eq 'R' ) {
$Tx = ( $text_box_width - $string_width ) + ( ( $origin_llx - $text_llx ) / 2 );
return $Tx, $Tw;
}
elsif ($alignment eq 'L') {
} elsif ( $alignment eq 'L' ) {
return $origin_llx, $Tw;
}
else { # if we are not handed an alignment default to left align text...
} else { # if we are not handed an alignment default to left align text...
return $origin_llx, $Tw;
}
}
sub leading {
return $_[0] + ($_[0] * 0.20); # recommended starting point for leading is 20% of the font point size (See http://www.bastoky.com/KeyRelations.htm)
return $_[0] +
( $_[0] * 0.20 )
; # recommended starting point for leading is 20% of the font point size (See http://www.bastoky.com/KeyRelations.htm)
}
sub box {
@ -98,6 +96,7 @@ sub get_borrower_attributes {
}
$query .= " FROM borrowers WHERE borrowernumber = ?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
$sth->execute($borrower_number);
if ( $sth->err ) {
@ -130,7 +129,8 @@ sub put_image {
}
return 202 if $sth->fetchrow_array >= $image_limit;
}
my$query = "INSERT INTO creator_images (imagefile, image_name) VALUES (?,?) ON DUPLICATE KEY UPDATE imagefile = ?;";
my $query =
"INSERT INTO creator_images (imagefile, image_name) VALUES (?,?) ON DUPLICATE KEY UPDATE imagefile = ?;";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( $image_file, $image_name, $image_file );
if ( $sth->err ) {
@ -148,8 +148,7 @@ sub get_image {
my $sth = C4::Context->dbh->prepare($query);
if ($image_name) {
$sth->execute($image_name);
}
else {
} else {
$sth->execute();
}
if ( $sth->err ) {
@ -173,8 +172,7 @@ sub rm_image {
}
if ($errstr) {
return $errstr;
}
else {
} else {
return;
}
}

66
C4/Patroncards/Patroncard.pm
View File

@ -21,6 +21,7 @@ use strict;
use warnings;
use autouse 'Data::Dumper' => qw(Dumper);
#use Font::TTFMetrics;
use C4::Creators::Lib qw( get_unit_values );
@ -69,6 +70,7 @@ sub new {
my $self = {
batch_id => $params{'batch_id'},
#card_number => $params{'card_number'},
borrower_number => $params{'borrower_number'},
llx => $params{'llx'},
@ -150,7 +152,12 @@ sub draw_guide_grid {
my $y = $self->{'lly'};
my $cnt = 0;
for ( $x = $self->{'llx'}/$self->{'unitvalue'}; $x <= ($self->{'llx'} + $self->{'width'})/$self->{'unitvalue'}; $x++) {
for (
$x = $self->{'llx'} / $self->{'unitvalue'} ;
$x <= ( $self->{'llx'} + $self->{'width'} ) / $self->{'unitvalue'} ;
$x++
)
{
my $xx = $x * $self->{'unitvalue'};
my $yy = $y + $self->{'height'};
if ( ( $cnt % 10 ) && !( $cnt % 5 ) ) {
@ -174,7 +181,12 @@ sub draw_guide_grid {
$x = $self->{'llx'};
$y = $self->{'lly'};
$cnt = 0;
for ( $y = $self->{'lly'}/$self->{'unitvalue'}; $y <= ($self->{'lly'} + $self->{'height'})/$self->{'unitvalue'}; $y++) {
for (
$y = $self->{'lly'} / $self->{'unitvalue'} ;
$y <= ( $self->{'lly'} + $self->{'height'} ) / $self->{'unitvalue'} ;
$y++
)
{
my $xx = $x + $self->{'width'};
my $yy = $y * $self->{'unitvalue'};
@ -201,13 +213,17 @@ sub draw_guide_grid {
# Add info about units
my $strbottom = "0/0 $self->{'unitdesc'}";
my $strtop = sprintf('%.2f', $self->{'width'}/$self->{'unitvalue'}) .'/'. sprintf('%.2f', $self->{'height'}/$self->{'unitvalue'});
my $strtop = sprintf( '%.2f', $self->{'width'} / $self->{'unitvalue'} ) . '/'
. sprintf( '%.2f', $self->{'height'} / $self->{'unitvalue'} );
my $font_size = 6;
$pdf->Font('Courier');
$pdf->FontSize($font_size);
my $strtop_len = $pdf->StrWidth($strtop) * 1.5;
$pdf->Text( $self->{'llx'} + 2, $self->{'lly'} + 2, $strbottom );
$pdf->Text( $self->{'llx'} + $self->{'width'} - $strtop_len , $self->{'lly'} + $self->{'height'} - $font_size , $strtop );
$pdf->Text(
$self->{'llx'} + $self->{'width'} - $strtop_len, $self->{'lly'} + $self->{'height'} - $font_size,
$strtop
);
}
=head2 draw_text
@ -257,9 +273,11 @@ sub draw_text {
my $Tx = 0; # final text llx
my $Ty = $origin_lly; # final text lly
my $Tw = 0; # final text word spacing. See http://www.adobe.com/devnet/pdf/pdf_reference.html ISO 32000-1
#FIXME: Move line wrapping code to its own sub if possible
my $trim = '';
my @lines = ();
#FIXME: Using embedded True Type fonts is a far superior way of handing things as well as being much more unicode friendly.
# However this will take significant work using better than PDF::Reuse to do it. For the time being, I'm leaving
# the basic code here commented out to preserve the basic method of accomplishing this. -chris_n
@ -313,6 +331,7 @@ sub draw_text {
last WRAP_LINES;
}
} else {
# We only split lines on spaces - it seems if we push a line too far, it can end
# never getting short enough in which case we need to escape and the malformed PDF
# will indicate the layout problem
@ -320,12 +339,15 @@ sub draw_text {
$cur_line = $line;
}
}
}
else {
($Tx, $Tw) = text_alignment($origin_llx, $self->{'width'}, $lly_text_attr * $self->{'unitvalue'}, $string_width, $line, $text_attribs->{'text_alignment'});
} else {
( $Tx, $Tw ) = text_alignment(
$origin_llx, $self->{'width'}, $lly_text_attr * $self->{'unitvalue'}, $string_width,
$line, $text_attribs->{'text_alignment'}
);
$line =~ s/^\s+//g; # strip naughty leading spaces
push @lines, { line => $line, Tx => $Tx, Ty => $Ty, Tw => $Tw };
}
# Draw boxes around text box areas
# FIXME: This needs to compensate for the point height of decenders. In its current form it is helpful but not really usable. The boxes are also not transparent atm.
# If these things were fixed, it may be desirable to give the user control over whether or not to display these boxes for layout design.
@ -335,11 +357,13 @@ sub draw_text {
if ( scalar(@lines) > 1 ) {
$box_height += scalar(@lines) * ( $text_attribs->{'font_size'} * 1.2 );
$box_lly -= ( $text_attribs->{'font_size'} * 0.2 );
}
else {
} else {
$box_height += $text_attribs->{'font_size'};
}
box ($origin_llx, $box_lly, $self->{'width'} - ( $text_attribs->{'llx'} * $self->{'unitvalue'} ), $box_height, $pdf);
box(
$origin_llx, $box_lly, $self->{'width'} - ( $text_attribs->{'llx'} * $self->{'unitvalue'} ),
$box_height, $pdf
);
}
$pdf->Font( $text_attribs->{'font'} );
$pdf->FontSize( $text_attribs->{'font_size'} );
@ -368,9 +392,15 @@ sub draw_image {
my $Tx = $self->{'llx'} + $images->{$image}->{'Tx'} * $self->{'unitvalue'};
my $Ty = $self->{'lly'} + $images->{$image}->{'Ty'} * $self->{'unitvalue'};
warn sprintf('No image passed in.') and next if !$images->{$image}->{'data'};
my $intName = $pdf->AltJpeg($images->{$image}->{'data'},$images->{$image}->{'Sx'}, $images->{$image}->{'Sy'}, 1, $images->{$image}->{'alt'}->{'data'},$images->{$image}->{'alt'}->{'Sx'}, $images->{$image}->{'alt'}->{'Sy'}, 1);
my $intName = $pdf->AltJpeg(
$images->{$image}->{'data'}, $images->{$image}->{'Sx'}, $images->{$image}->{'Sy'}, 1,
$images->{$image}->{'alt'}->{'data'}, $images->{$image}->{'alt'}->{'Sx'},
$images->{$image}->{'alt'}->{'Sy'}, 1
);
my $obj_stream = "q\n";
$obj_stream .= "$images->{$image}->{'Sx'} $images->{$image}->{'Ox'} $images->{$image}->{'Oy'} $images->{$image}->{'Sy'} $Tx $Ty cm\n"; # see http://www.adobe.com/devnet/pdf/pdf_reference.html sec 8.3.3 of ISO 32000-1
$obj_stream .=
"$images->{$image}->{'Sx'} $images->{$image}->{'Ox'} $images->{$image}->{'Oy'} $images->{$image}->{'Sy'} $Tx $Ty cm\n"
; # see http://www.adobe.com/devnet/pdf/pdf_reference.html sec 8.3.3 of ISO 32000-1
$obj_stream .= "$images->{$image}->{'scale'} 0 0 $images->{$image}->{'scale'} 0 0 cm\n"; #scale to 20%
$obj_stream .= "/$intName Do\n";
$obj_stream .= "Q\n";
@ -397,13 +427,13 @@ sub _draw_barcode { # this is cut-and-paste from Label.pm because there is no
my $guard_length = 10;
if ( $params{'barcode_type'} =~ m/CODE39/ ) {
$bar_length = '17.5';
$tot_bar_length = ($bar_length * $num_of_chars) + ($guard_length * 2); # not sure what all is going on here and on the next line; this is old (very) code
$tot_bar_length = ( $bar_length * $num_of_chars ) +
( $guard_length * 2 ); # not sure what all is going on here and on the next line; this is old (very) code
$x_scale_factor = ( $params{'width'} / $tot_bar_length );
if ( $params{'barcode_type'} eq 'CODE39MOD' ) {
my $c39 = CheckDigits('code_39'); # get modulo 43 checksum
$params{'barcode_data'} = $c39->complete( $params{'barcode_data'} );
}
elsif ($params{'barcode_type'} eq 'CODE39MOD10') {
} elsif ( $params{'barcode_type'} eq 'CODE39MOD10' ) {
my $c39_10 = CheckDigits('siret'); # get modulo 10 checksum
$params{'barcode_data'} = $c39_10->complete( $params{'barcode_data'} );
}
@ -422,8 +452,7 @@ sub _draw_barcode { # this is cut-and-paste from Label.pm because there is no
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
elsif ($params{'barcode_type'} eq 'COOP2OF5') {
} elsif ( $params{'barcode_type'} eq 'COOP2OF5' ) {
$bar_length = '9.43333333333333';
$tot_bar_length = ( $bar_length * $num_of_chars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
@ -440,8 +469,7 @@ sub _draw_barcode { # this is cut-and-paste from Label.pm because there is no
if ($@) {
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
elsif ( $params{'barcode_type'} eq 'INDUSTRIAL2OF5' ) {
} elsif ( $params{'barcode_type'} eq 'INDUSTRIAL2OF5' ) {
$bar_length = '13.1333333333333';
$tot_bar_length = ( $bar_length * $num_of_chars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;

4
C4/Patroncards/Profile.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Profile);
use autouse 'Data::Dumper' => qw(Dumper);
__PACKAGE__ =~ m/^C4::(.+)::.+$/;
my $me = $1;
@ -34,8 +33,7 @@ sub delete {
my $self = shift; # check to see if this is a method call
push @_, "creator", $me;
return $self->SUPER::delete(@_);
}
else {
} else {
push @_, "creator", $me;
return __PACKAGE__->SUPER::delete(@_); # XXX: is this too hackish?
}

1
C4/Patroncards/Template.pm
View File

@ -7,7 +7,6 @@ use base qw(C4::Creators::Template);
use autouse 'Data::Dumper' => qw(Dumper);
use constant TEMPLATE_TABLE => 'creator_templates';
__PACKAGE__ =~ m/^C4::(.+)::.+$/;

115
C4/Record.pm
View File

@ -43,7 +43,6 @@ use Carp qw( carp croak );
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
# only export API methods
@ -92,12 +91,14 @@ sub marc2marc {
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 };
if ($@) { $error .= "\nCreation of MARC::Record object failed: " . $MARC::File::ERROR }
}
unless ($error) {
my @privatefields;
foreach my $field ( $marc_record_obj->fields() ) {
if ($field->tag() =~ m/9/ && ($field->tag() != '490' || C4::Context->preference("marcflavour") eq 'UNIMARC')) {
if ( $field->tag() =~ m/9/
&& ( $field->tag() != '490' || C4::Context->preference("marcflavour") eq 'UNIMARC' ) )
{
push @privatefields, $field;
} elsif ( !( $field->is_control_field() ) ) {
$field->delete_subfield( code => '9' ) if ( $field->subfield('9') );
@ -141,19 +142,23 @@ sub marc2marcxml {
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 };
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 };
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
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
@ -163,7 +168,7 @@ sub marc2marcxml {
$error .= "Creation of MARCXML failed:" . $MARC::File::ERROR;
$error .= "Additional information:\n";
my @warnings = $@->warnings();
foreach my $warn (@warnings) { $error.=$warn."\n" };
foreach my $warn (@warnings) { $error .= $warn . "\n" }
# record creation was successful
} else {
@ -171,8 +176,9 @@ sub marc2marcxml {
# 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 };
warn "\nWarnings encountered while processing ISO-2709 record with title \""
. $marc_record_obj->title() . "\":\n";
foreach my $warn (@warnings) { warn "\t" . $warn }
}
}
@ -186,6 +192,7 @@ sub marc2marcxml {
}
}
}
# return result to calling program
return ( $error, $marcxml );
}
@ -208,16 +215,20 @@ 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
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: ".$@;
if ($@) {
$error .= "\nCreation of MARCXML Record failed: " . $@;
$error .= $MARC::File::ERROR if ($MARC::File::ERROR);
};
}
# return result to calling program
return ( $error, $marc );
}
@ -254,20 +265,26 @@ sub marc2dcxml {
# set the default path for intranet xslts
# differents xslts to process (OAIDC, SRWDC and RDFDC)
my $xsl = C4::Context->config('intrahtdocs') . '/prog/en/xslt/' .
C4::Context->preference('marcflavour') . 'slim2' . uc ( $format ) . '.xsl';
my $xsl =
C4::Context->config('intrahtdocs')
. '/prog/en/xslt/'
. C4::Context->preference('marcflavour') . 'slim2'
. uc($format) . '.xsl';
if ( defined $marc ) {
# no need to catch errors or warnings marc2marcxml do it instead
$marcxml = C4::Record::marc2marcxml($marc);
} elsif ( not defined $xml and defined $biblionumber ) {
# get MARCXML biblio directly without item information
$marcxml = C4::Biblio::GetXmlBiblio($biblionumber);
} else {
$marcxml = $xml;
}
eval { $record = MARC::Record->new_from_xml(
eval {
$record = MARC::Record->new_from_xml(
$marcxml,
'UTF-8',
C4::Context->preference('marcflavour')
@ -282,14 +299,14 @@ sub marc2dcxml {
my @warnings = $record->warnings();
foreach my $warn (@warnings) {
carp "\t" . $warn;
};
}
} elsif ( $record =~ /^MARC::Record/ ) { # if OK makes xslt transformation
my $xslt_engine = Koha::XSLT::Base->new;
if ( $format =~ /^(dc|oaidc|srwdc|rdfdc)$/i ) {
$output = $xslt_engine->transform( $marcxml, $xsl );
} else {
croak "The format argument ($format) not accepted.\n" .
"Please pass a valid format (oaidc, srwdc, or rdfdc)\n";
croak "The format argument ($format) not accepted.\n"
. "Please pass a valid format (oaidc, srwdc, or rdfdc)\n";
}
my $err = $xslt_engine->err; # error code
if ($err) {
@ -337,6 +354,7 @@ contain the path to a stylesheet under intrahtdocs.
sub _transformWithStylesheet {
my ( $marc, $stylesheet ) = @_;
# grab the XML, run it through our stylesheet, push it out to the browser
my $xmlrecord = marc2marcxml($marc);
my $xslfile = C4::Context->config('intrahtdocs') . $stylesheet;
@ -473,6 +491,7 @@ sub marcrecord2csv {
# Getting output encoding
my $encoding = $profile->encoding || 'utf8';
# Getting separators
my $csvseparator = $profile->csv_separator || ',';
my $fieldseparator = $profile->field_separator || '#';
@ -499,7 +518,8 @@ sub marcrecord2csv {
my @csv_structures;
foreach (@marcfieldsarray) {
my @result = split( '=', $_, 2 );
my $content = ( @result == 2 )
my $content =
( @result == 2 )
? $result[1]
: $result[0];
my @fields;
@ -511,7 +531,7 @@ sub marcrecord2csv {
if ( @result == 2 ) {
push @csv_structures, { header => $result[0], content => $content, fields => \@fields };
} else {
push @csv_structures, { content => $content, fields => \@fields }
push @csv_structures, { content => $content, fields => \@fields };
}
}
@ -533,6 +553,7 @@ sub marcrecord2csv {
push @{ $values->{$subfieldtag} }, $value;
}
}
# We force the key as an integer (trick for 00X and OXX fields)
push @{ $field_list->{fields}{ 0 + $fieldtag } }, $values;
}
@ -544,10 +565,12 @@ sub marcrecord2csv {
my $content = $csv_structure->{content};
if ($header) {
# If we have a user-supplied header, we use it
if ( exists $csv_structure->{header} ) {
push @marcfieldsheaders, $csv_structure->{header};
} else {
# If not, we get the matching tag name from koha
my $tag = $tags->[0];
if ( defined $tag->{subfieldtag} ) {
@ -564,6 +587,7 @@ sub marcrecord2csv {
# TT tags exist
if ( $content =~ m|\[\%.*\%\]| ) {
# Replace 00X and 0XX with X or XX
$content =~ s|fields.00(\d)|fields.$1|g;
$content =~ s|fields.0(\d{2})|fields.$1|g;
@ -572,6 +596,7 @@ sub marcrecord2csv {
} else {
for my $tag (@$tags) {
my @fields = $record->field( $tag->{fieldtag} );
# If it is a subfield
my @loop_values;
if ( defined $tag->{subfieldtag} ) {
@ -581,11 +606,15 @@ sub marcrecord2csv {
tagsubfield => $tag->{subfieldtag},
}
);
# For each field
foreach my $field (@fields) {
my @subfields = $field->subfield( $tag->{subfieldtag} );
foreach my $subfield (@subfields) {
push @loop_values, (defined $av_description_mapping->{$subfield}) ? $av_description_mapping->{$subfield} : $subfield;
push @loop_values,
( defined $av_description_mapping->{$subfield} )
? $av_description_mapping->{$subfield}
: $subfield;
}
}
@ -599,8 +628,12 @@ sub marcrecord2csv {
if ( $field->is_control_field ) {
my $authvalues = Koha::AuthorisedValues->get_descriptions_by_marc_field(
{ frameworkcode => $frameworkcode, tagfield => $tag->{fieldtag}, } );
$value = defined $authvalues->{$field->as_string} ? $authvalues->{$field->as_string} : $field->as_string;
$value =
defined $authvalues->{ $field->as_string }
? $authvalues->{ $field->as_string }
: $field->as_string;
} else {
# If it is a field, we gather all subfields, joined by the subfield separator
my @subvaluesarray;
my @subfields = $field->subfields;
@ -611,7 +644,12 @@ sub marcrecord2csv {
tagsubfield => $subfield->[0],
}
);
push (@subvaluesarray, defined $authvalues->{$subfield->[1]} ? $authvalues->{$subfield->[1]} : $subfield->[1]);
push(
@subvaluesarray,
defined $authvalues->{ $subfield->[1] }
? $authvalues->{ $subfield->[1] }
: $subfield->[1]
);
}
$value = join( $subfieldseparator, @subvaluesarray );
}
@ -641,7 +679,6 @@ sub marcrecord2csv {
}
}
if ($header) {
$csv->combine(@marcfieldsheaders);
$output = $csv->string() . "\n";
@ -653,7 +690,6 @@ sub marcrecord2csv {
}
=head2 changeEncoding - Change the encoding of a record
my ($error, $newrecord) = changeEncoding($record,$format,$flavour,$to_encoding,$from_encoding);
@ -682,11 +718,12 @@ 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"};
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
@ -721,7 +758,6 @@ C<$id> - an id for the BibTex record (might be the biblionumber)
=cut
sub marc2bibtex {
my ( $record, $id ) = @_;
my $tex;
@ -734,6 +770,7 @@ sub marc2bibtex {
@authorFields = ( '700', '701', '702', '710', '711', '721' ) if ( $marcflavour eq "UNIMARC" );
foreach my $field (@authorFields) {
# author formatted surname, firstname
my $texauthor = '';
if ( $marcflavour eq "UNIMARC" ) {
@ -781,7 +818,10 @@ sub marc2bibtex {
title => $record->subfield( "245", "a" ) || "",
editor => $record->subfield( "260", "f" ) || "",
publisher => $record->subfield( "264", "b" ) || $record->subfield( "260", "b" ) || "",
year => $record->subfield("264", "c") || $record->subfield("260", "c") || $record->subfield("260", "g") || "",
year => $record->subfield( "264", "c" )
|| $record->subfield( "260", "c" )
|| $record->subfield( "260", "g" )
|| "",
# Optional
# unimarc to marc21 specification says not to convert 200$v to marc21
@ -801,12 +841,10 @@ sub marc2bibtex {
if ($type) {
$tex .= '@' . $type . '{';
}
else {
} else {
$tex .= "\@book{";
}
}
else {
} else {
$tex .= "\@book{";
}
@ -835,8 +873,7 @@ sub marc2bibtex {
}
}
}
}
else {
} else {
$tex .= "\n";
}
@ -845,7 +882,6 @@ sub marc2bibtex {
return $tex;
}
=head2 marc2cites - Convert from MARC21 and UNIMARC to citations
my $cites = marc2cites($record);
@ -957,7 +993,6 @@ sub marc2cites {
return \%cites;
}
=head1 INTERNAL FUNCTIONS
=head2 _entity_encode - Entity-encode an array of strings

1
C4/Reports.pm
View File

@ -23,6 +23,7 @@ use CGI qw ( -utf8 );
use C4::Context;
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);

166
C4/Reports/Guided.pm
View File

@ -40,6 +40,7 @@ use Koha::SharedContent;
use Koha::TemplateUtils qw( process_tt );
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -90,9 +91,7 @@ sub get_area_name_sql_snippet {
[ SER => "Serials" ],
);
return "CASE report_area " .
join (" ", map "WHEN '$_->[0]' THEN '$_->[1]'", @REPORT_AREA) .
" END AS areaname";
return "CASE report_area " . join( " ", map "WHEN '$_->[0]' THEN '$_->[1]'", @REPORT_AREA ) . " END AS areaname";
}
sub get_report_areas {
@ -109,7 +108,10 @@ sub get_table_areas {
PAT => ['borrowers'],
ACQ => [ 'aqorders', 'biblio', 'items' ],
ACC => [ 'borrowers', 'accountlines' ],
SER => [ 'serial', 'serialitems', 'subscription', 'subscriptionhistory', 'subscriptionroutinglist', 'biblioitems', 'biblio', 'aqbooksellers' ],
SER => [
'serial', 'serialitems', 'subscription', 'subscriptionhistory', 'subscriptionroutinglist', 'biblioitems',
'biblio', 'aqbooksellers'
],
);
}
@ -147,10 +149,12 @@ sub get_report_groups {
my $groups = GetAuthorisedValues('REPORT_GROUP');
my $subgroups = GetAuthorisedValues('REPORT_SUBGROUP');
my %groups_with_subgroups = map { $_->{authorised_value} => {
my %groups_with_subgroups = map {
$_->{authorised_value} => {
name => $_->{lib},
groups => {}
} } @$groups;
}
} @$groups;
foreach (@$subgroups) {
my $sg = $_->{authorised_value};
my $g = $_->{lib_opac}
@ -161,7 +165,7 @@ sub get_report_groups {
next;
$g_sg->{subgroups}{$sg} = $_->{lib};
}
return \%groups_with_subgroups
return \%groups_with_subgroups;
}
=head2 get_all_tables
@ -236,26 +240,36 @@ sub build_query {
my ( $columns, $criteria, $orderby, $area, $totals, $definition ) = @_;
my %keys = (
CIRC => [ 'statistics.borrowernumber=borrowers.borrowernumber',
CIRC => [
'statistics.borrowernumber=borrowers.borrowernumber',
'items.itemnumber = statistics.itemnumber',
'biblioitems.biblioitemnumber = items.biblioitemnumber' ],
CAT => [ 'items.biblioitemnumber=biblioitems.biblioitemnumber',
'biblioitems.biblionumber=biblio.biblionumber' ],
'biblioitems.biblioitemnumber = items.biblioitemnumber'
],
CAT => [
'items.biblioitemnumber=biblioitems.biblioitemnumber',
'biblioitems.biblionumber=biblio.biblionumber'
],
PAT => [],
ACQ => [ 'aqorders.biblionumber=biblio.biblionumber',
'biblio.biblionumber=items.biblionumber' ],
ACQ => [
'aqorders.biblionumber=biblio.biblionumber',
'biblio.biblionumber=items.biblionumber'
],
ACC => ['borrowers.borrowernumber=accountlines.borrowernumber'],
SER => [ 'serial.serialid=serialitems.serialid', 'serial.subscriptionid=subscription.subscriptionid', 'serial.subscriptionid=subscriptionhistory.subscriptionid', 'serial.subscriptionid=subscriptionroutinglist.subscriptionid', 'biblioitems.biblionumber=serial.biblionumber', 'biblio.biblionumber=biblioitems.biblionumber', 'subscription.aqbooksellerid=aqbooksellers.id'],
SER => [
'serial.serialid=serialitems.serialid', 'serial.subscriptionid=subscription.subscriptionid',
'serial.subscriptionid=subscriptionhistory.subscriptionid',
'serial.subscriptionid=subscriptionroutinglist.subscriptionid',
'biblioitems.biblionumber=serial.biblionumber', 'biblio.biblionumber=biblioitems.biblionumber',
'subscription.aqbooksellerid=aqbooksellers.id'
],
);
### $orderby
my $keys = $keys{$area};
my %table_areas = get_table_areas;
my $tables = $table_areas{$area};
my $sql =
_build_query( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition );
my $sql = _build_query( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition );
return ($sql);
}
@ -266,8 +280,7 @@ sub _build_query {
my $dbh = C4::Context->dbh();
my $joinedtables = join( ',', @$tables );
my $joinedcolumns = join( ',', @$columns );
my $query =
"SELECT $totals $joinedcolumns FROM $tables->[0] ";
my $query = "SELECT $totals $joinedcolumns FROM $tables->[0] ";
for ( my $i = 1 ; $i < @$tables ; $i++ ) {
$query .= "LEFT JOIN $tables->[$i] on ($keys->[$i-1]) ";
}
@ -285,8 +298,7 @@ sub _build_query {
}
if ( $query =~ /WHERE/i ) {
$query .= $deftext;
}
else {
} else {
$deftext =~ s/AND/WHERE/;
$query .= $deftext;
}
@ -298,8 +310,7 @@ sub _build_query {
if ( $total =~ /\((.*)\)/ ) {
if ( $groupby eq '' ) {
$groupby = " GROUP BY $1";
}
else {
} else {
$groupby .= ",$1";
}
}
@ -324,19 +335,26 @@ sub get_criteria {
# have to do someting here to know if its dropdown, free text, date etc
my %criteria = (
CIRC => [ 'statistics.type', 'borrowers.categorycode', 'statistics.branch',
'biblioitems.publicationyear|date', 'items.dateaccessioned|date' ],
CAT => [ 'items.itemnumber|textrange', 'items.biblionumber|textrange',
CIRC => [
'statistics.type', 'borrowers.categorycode', 'statistics.branch',
'biblioitems.publicationyear|date', 'items.dateaccessioned|date'
],
CAT => [
'items.itemnumber|textrange', 'items.biblionumber|textrange',
'items.barcode|textrange', 'biblio.frameworkcode',
'items.holdingbranch', 'items.homebranch',
'biblio.datecreated|daterange', 'biblio.timestamp|daterange',
'items.onloan|daterange', 'items.ccode',
'items.itemcallnumber|textrange', 'items.itype', 'items.itemlost',
'items.location' ],
'items.location'
],
PAT => [ 'borrowers.branchcode', 'borrowers.categorycode' ],
ACQ => ['aqorders.datereceived|date'],
ACC => [ 'borrowers.branchcode', 'borrowers.categorycode' ],
SER => ['subscription.startdate|date', 'subscription.enddate|date', 'subscription.periodicity', 'subscription.callnumber', 'subscription.location', 'subscription.branchcode'],
SER => [
'subscription.startdate|date', 'subscription.enddate|date', 'subscription.periodicity',
'subscription.callnumber', 'subscription.location', 'subscription.branchcode'
],
);
# Adds itemtypes to criteria, according to the syspref
@ -348,7 +366,6 @@ sub get_criteria {
unshift @{ $criteria{'CAT'} }, 'biblioitems.itemtype';
}
my $crit = $criteria{$area};
my $columns = Koha::Database::Columns->columns;
my @criteria_array;
@ -364,15 +381,13 @@ sub get_criteria {
$temp{'textrange'} = 1;
$temp{'description'} = $description;
push @criteria_array, \%temp;
}
elsif ($type eq 'date') {
} elsif ( $type eq 'date' ) {
my %temp;
$temp{'name'} = $value;
$temp{'date'} = 1;
$temp{'description'} = $description;
push @criteria_array, \%temp;
}
elsif ($type eq 'daterange') {
} elsif ( $type eq 'daterange' ) {
my %temp;
$temp{'name'} = $value;
$temp{'from'} = "from_" . $value;
@ -380,19 +395,19 @@ sub get_criteria {
$temp{'daterange'} = 1;
$temp{'description'} = $description;
push @criteria_array, \%temp;
}
else {
my $query =
"SELECT distinct($column) as availablevalues FROM $table";
} else {
my $query = "SELECT distinct($column) as availablevalues FROM $table";
my $sth = $dbh->prepare($query);
$sth->execute();
my @values;
# push the runtime choosing option
my $list;
$list = 'branches' if $column eq 'branchcode' or $column eq 'holdingbranch' or $column eq 'homebranch';
$list = 'categorycode' if $column eq 'categorycode';
$list = 'itemtypes' if $column eq 'itype';
$list = 'ccode' if $column eq 'ccode';
# TODO : improve to let the librarian choose the description at runtime
push @values, {
availablevalues => "<<$column" . ( $list ? "|$list" : '' ) . ">>",
@ -419,12 +434,12 @@ sub nb_rows {
my $sql = shift or return;
my $derived_name = 'xxx';
# make sure the derived table name is not already used
while ( $sql =~ m/$derived_name/ ) {
$derived_name .= 'x';
}
my $dbh = C4::Context->dbh;
my $sth;
my $n = 0;
@ -434,10 +449,12 @@ sub nb_rows {
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
eval {
$sth = $dbh->prepare(qq{
$sth = $dbh->prepare(
qq{
SELECT COUNT(*) FROM
( $sql ) $derived_name
});
}
);
$sth->execute();
};
@ -449,6 +466,7 @@ sub nb_rows {
$sth->execute;
};
warn $@ if $@;
# Loop through the complete results, fetching 1,000 rows at a time. This
# lowers memory requirements but increases execution time.
while ( my $rows = $sth->fetchall_arrayref( undef, 1000 ) ) {
@ -471,6 +489,7 @@ sub nb_rows {
=cut
sub select_2_select_count {
# Modify the query passed in to create a count query... (I think this covers all cases -crn)
my ($sql) = strip_limit(shift) or return;
$sql =~ s/\bSELECT\W+(?:\w+\W+){1,}?FROM\b|\bSELECT\W\*\WFROM\b/SELECT count(*) FROM /ig;
@ -606,16 +625,19 @@ sub execute_query {
$dbh->do( 'UPDATE saved_sql SET last_run = NOW() WHERE id = ?', undef, $report_id ) if $report_id;
Koha::Logger->get( { prefix => 0, interface => 'reports', category => 'execute.query' } )
->info("Report $report_id : $sql, $offset, $limit") if $report_id;
->info("Report $report_id : $sql, $offset, $limit")
if $report_id;
Koha::Logger->get( { prefix => 0, interface => 'reports', category => 'execute.time.start' } )
->info("Report starting: $report_id") if $report_id;
->info("Report starting: $report_id")
if $report_id;
my $sth = $dbh->prepare($sql);
eval { $sth->execute( @$sql_params, $offset, $limit ); };
warn $@ if $@;
Koha::Logger->get( { prefix => 0, interface => 'reports', category => 'execute.time.end' } )
->info("Report finished: $report_id") if $report_id;
->info("Report finished: $report_id")
if $report_id;
return ( $sth, { queryerr => $sth->errstr } ) if ( $sth->err );
@ -690,6 +712,7 @@ sub update_sql {
$report->cache_expiry($cache_expiry) if defined $cache_expiry;
$report->public($public);
$report->store();
if ( $cache_expiry >= 2592000 ) {
die "Please specify a cache expiry less than 30 days\n"; # That's a bit harsh
}
@ -700,20 +723,24 @@ sub update_sql {
sub store_results {
my ( $id, $json ) = @_;
my $dbh = C4::Context->dbh();
$dbh->do(q|
$dbh->do(
q|
INSERT INTO saved_reports ( report_id, report, date_run ) VALUES ( ?, ?, NOW() );
|, undef, $id, $json );
|, undef, $id, $json
);
}
sub format_results {
my ($id) = @_;
my $dbh = C4::Context->dbh();
my ( $report_name, $notes, $json, $date_run ) = $dbh->selectrow_array(q|
my ( $report_name, $notes, $json, $date_run ) = $dbh->selectrow_array(
q|
SELECT ss.report_name, ss.notes, sr.report, sr.date_run
FROM saved_sql ss
LEFT JOIN saved_reports sr ON sr.report_id = ss.id
WHERE sr.id = ?
|, undef, $id);
|, undef, $id
);
return {
report_name => $report_name,
notes => $notes,
@ -727,7 +754,8 @@ sub delete_report {
return unless @ids;
foreach my $id (@ids) {
my $data = Koha::Reports->find($id);
logaction( "REPORTS", "DELETE", $id, $data->report_name." | ".$data->savedsql ) if C4::Context->preference("ReportsLog");
logaction( "REPORTS", "DELETE", $id, $data->report_name . " | " . $data->savedsql )
if C4::Context->preference("ReportsLog");
}
my $dbh = C4::Context->dbh;
my $query = 'DELETE FROM saved_sql WHERE id IN (' . join( ',', ('?') x @ids ) . ')';
@ -749,6 +777,7 @@ EOQ
}
sub get_saved_reports {
# $filter is either { date => $d, author => $a, keyword => $kw, }
# or $keyword. Optional.
my ($filter) = @_;
@ -790,7 +819,8 @@ sub get_saved_reports {
}
}
$query .= " WHERE " . join( " AND ", map "($_)", @cond ) if @cond;
$query .= " GROUP BY s.id, s.borrowernumber, s.date_created, s.last_modified, s.savedsql, s.last_run, s.report_name, s.type, s.notes, s.cache_expiry, s.public, s.report_area, s.report_group, s.report_subgroup, s.mana_id, av_g.lib, av_sg.lib, b.firstname, b.surname";
$query .=
" GROUP BY s.id, s.borrowernumber, s.date_created, s.last_modified, s.savedsql, s.last_run, s.report_name, s.type, s.notes, s.cache_expiry, s.public, s.report_area, s.report_group, s.report_subgroup, s.mana_id, av_g.lib, av_sg.lib, b.firstname, b.surname";
$query .= " ORDER by date_created";
my $result = $dbh->selectall_arrayref( $query, { Slice => {} }, @args );
@ -817,6 +847,7 @@ sub get_column_type {
my $sth = $dbh->column_info( $catalog, $schema, $table, $tempcolumn ) || die $dbh->errstr;
while ( my $info = $sth->fetchrow_hashref() ) {
if ( $info->{'COLUMN_NAME'} eq $column ) {
#column we want
if ( $info->{'TYPE_NAME'} eq 'CHAR' || $info->{'TYPE_NAME'} eq 'VARCHAR' ) {
$info->{'TYPE_NAME'} = 'distinct';
@ -837,8 +868,7 @@ sub get_distinct_values {
my ($tablecolumn) = @_;
my ( $table, $column ) = split( /\./, $tablecolumn );
my $dbh = C4::Context->dbh();
my $query =
"SELECT distinct($column) as availablevalues FROM $table";
my $query = "SELECT distinct($column) as availablevalues FROM $table";
my $sth = $dbh->prepare($query);
$sth->execute();
return $sth->fetchall_arrayref( {} );
@ -911,11 +941,13 @@ sub get_sql {
sub get_results {
my ($report_id) = @_;
my $dbh = C4::Context->dbh;
return $dbh->selectall_arrayref(q|
return $dbh->selectall_arrayref(
q|
SELECT id, report, date_run
FROM saved_reports
WHERE report_id = ?
|, { Slice => {} }, $report_id);
|, { Slice => {} }, $report_id
);
}
=head2 GetReservedAuthorisedValues
@ -928,7 +960,8 @@ Returns a hash containig all reserved words
sub GetReservedAuthorisedValues {
my %reserved_authorised_values =
map { $_ => 1 } ( 'date',
map { $_ => 1 } (
'date',
'list',
'branches',
'itemtypes',
@ -937,12 +970,12 @@ sub GetReservedAuthorisedValues {
'biblio_framework',
'cash_registers',
'debit_types',
'credit_types' );
'credit_types'
);
return \%reserved_authorised_values;
}
=head2 IsAuthorisedValueValid
my $is_valid_ath_value = IsAuthorisedValueValid($authorised_value)
@ -957,8 +990,9 @@ sub IsAuthorisedValueValid {
my $authorised_value = shift;
my $reserved_authorised_values = GetReservedAuthorisedValues();
if ( exists $reserved_authorised_values->{$authorised_value} ||
Koha::AuthorisedValues->search({ category => $authorised_value })->count ) {
if ( exists $reserved_authorised_values->{$authorised_value}
|| Koha::AuthorisedValues->search( { category => $authorised_value } )->count )
{
return 1;
}
@ -1005,8 +1039,8 @@ sub ValidateSQLParameters {
foreach my $sql_parameter (@$sql_parameters) {
if ( defined $sql_parameter->{'authval'} ) {
push @problematic_parameters, $sql_parameter unless
IsAuthorisedValueValid($sql_parameter->{'authval'});
push @problematic_parameters, $sql_parameter
unless IsAuthorisedValueValid( $sql_parameter->{'authval'} );
}
}
@ -1037,13 +1071,15 @@ sub EmailReport {
return ( undef, [ { FATAL => "MISSING_PARAMS" } ] ) unless ( $report_id && $module && $code );
return ( undef, [{ FATAL => "NO_LETTER" }] ) unless
my $letter = Koha::Notice::Templates->find({
return ( undef, [ { FATAL => "NO_LETTER" } ] )
unless my $letter = Koha::Notice::Templates->find(
{
module => $module,
code => $code,
branchcode => $branch,
message_transport_type => 'email',
});
}
);
$letter = $letter->unblessed;
$letter->{'content-type'} = 'text/html; charset="UTF-8"' if $letter->{'is_html'};
@ -1064,7 +1100,8 @@ sub EmailReport {
push( @errors, { NO_BOR_COL => $counter } ) unless defined $row->{borrowernumber};
push( @errors, { NO_EMAIL_COL => $counter } ) unless ( defined $row->{$email_col} );
push( @errors, { NO_FROM_COL => $counter } ) unless defined( $from || $row->{from} );
push ( @errors, { NO_BOR => $row->{borrowernumber} } ) unless Koha::Patrons->find({borrowernumber=>$row->{borrowernumber}});
push( @errors, { NO_BOR => $row->{borrowernumber} } )
unless Koha::Patrons->find( { borrowernumber => $row->{borrowernumber} } );
my $from_address = $from || $row->{from};
my $to_address = $row->{$email_col};
@ -1097,7 +1134,6 @@ sub _get_display_value {
return $original_value;
}
=head3 convert_sql
my $updated_sql = C4::Reports::Guided::convert_sql( $sql );

351
C4/Reserves.pm
View File

@ -20,7 +20,6 @@ package C4::Reserves;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Accounts;
@ -97,6 +96,7 @@ This modules provides somes functions to deal with reservations.
=cut
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -215,13 +215,15 @@ sub AddReserve {
&& ( $item->damaged && C4::Context->preference('AllowHoldsOnDamagedItems') || !$item->damaged )
# Lastly, if this already has holds, we shouldn't make it waiting for the new hold
&& !$item->current_holds->count )
&& !$item->current_holds->count
)
{
$priority = 0;
$found = 'W';
}
}
if ( C4::Context->preference('AllowHoldDateInFuture') ) {
# Make room in reserves for this if passed a priority
$priority = _ShiftPriority( $biblionumber, $priority );
}
@ -277,7 +279,8 @@ sub AddReserve {
if ( C4::Context->preference("emailLibrarianWhenHoldIsPlaced") ) {
my $patron = $hold->patron;
my $library = $patron->library;
if ( my $letter = C4::Letters::GetPreparedLetter (
if (
my $letter = C4::Letters::GetPreparedLetter(
module => 'reserves',
letter_code => 'HOLDPLACED',
branchcode => $branch,
@ -290,7 +293,9 @@ sub AddReserve {
'items' => $checkitem,
'reserves' => $hold->unblessed,
},
) ) {
)
)
{
my $branch_email_address = $library->inbound_email_address;
@ -341,11 +346,8 @@ sub AddReserve {
}
);
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
{
biblio_ids => [ $biblionumber ]
}
) if C4::Context->preference('RealTimeHoldsQueue');
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue( { biblio_ids => [$biblionumber] } )
if C4::Context->preference('RealTimeHoldsQueue');
return $reserve_id;
}
@ -366,7 +368,8 @@ sub CanBookBeReserved{
# Check that patron have not checked out this biblio (if AllowHoldsOnPatronsPossessions set)
if ( !C4::Context->preference('AllowHoldsOnPatronsPossessions')
&& C4::Circulation::CheckIfIssuedToPatron( $borrowernumber, $biblionumber ) ) {
&& C4::Circulation::CheckIfIssuedToPatron( $borrowernumber, $biblionumber ) )
{
return { status => 'alreadypossession' };
}
@ -392,9 +395,7 @@ sub CanBookBeReserved{
{ 'item.itype' => $params->{itemtype} }
]
},
{
join => ['item']
}
{ join => ['item'] }
)->count;
return { status => '' }
@ -402,15 +403,18 @@ sub CanBookBeReserved{
}
my $items;
#get items linked via host records
my @hostitemnumbers = get_hostitemnumbers_of($biblionumber);
if (@hostitemnumbers) {
$items = Koha::Items->search({
$items = Koha::Items->search(
{
-or => [
biblionumber => $biblionumber,
itemnumber => { -in => @hostitemnumbers }
]
});
}
);
} else {
$items = Koha::Items->search( { biblionumber => $biblionumber } );
}
@ -449,6 +453,7 @@ sub CanBookBeReserved{
=cut
our $CanItemBeReserved_cache_key;
sub _cache {
my ($return) = @_;
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
@ -460,7 +465,8 @@ sub CanItemBeReserved {
my ( $patron, $item, $pickup_branchcode, $params ) = @_;
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
$CanItemBeReserved_cache_key = sprintf "Hold_CanItemBeReserved:%s:%s:%s", $patron->borrowernumber, $item->itemnumber, $pickup_branchcode || "";
$CanItemBeReserved_cache_key = sprintf "Hold_CanItemBeReserved:%s:%s:%s", $patron->borrowernumber,
$item->itemnumber, $pickup_branchcode || "";
if ( $params->{get_from_cache} ) {
my $cached = $memory_cache->get_from_cache($CanItemBeReserved_cache_key);
return $cached if $cached;
@ -487,18 +493,23 @@ sub CanItemBeReserved {
if ( GetMarcFromKohaField('biblioitems.agerestriction') ) {
my $biblio = $item->biblio;
# Check for the age restriction
my $ageRestriction = C4::Circulation::GetAgeRestriction( $biblio->biblioitem->agerestriction );
return _cache { status => 'ageRestricted' } if $ageRestriction && $patron->dateofbirth && $ageRestriction > $patron->get_age();
return _cache { status => 'ageRestricted' }
if $ageRestriction && $patron->dateofbirth && $ageRestriction > $patron->get_age();
}
# Check that the patron doesn't have an item level hold on this item already
return _cache { status => 'itemAlreadyOnHold' }
if ( !$params->{ignore_hold_counts} && Koha::Holds->search( { borrowernumber => $patron->borrowernumber, itemnumber => $item->itemnumber } )->count() );
if ( !$params->{ignore_hold_counts}
&& Koha::Holds->search( { borrowernumber => $patron->borrowernumber, itemnumber => $item->itemnumber } )
->count() );
# Check that patron have not checked out this biblio (if AllowHoldsOnPatronsPossessions set)
if ( !C4::Context->preference('AllowHoldsOnPatronsPossessions')
&& C4::Circulation::CheckIfIssuedToPatron( $patron->borrowernumber, $item->biblionumber ) ) {
&& C4::Circulation::CheckIfIssuedToPatron( $patron->borrowernumber, $item->biblionumber ) )
{
return _cache { status => 'alreadypossession' };
}
@ -514,34 +525,37 @@ sub CanItemBeReserved {
if ( $controlbranch eq "ItemHomeLibrary" ) {
$branchfield = "items.homebranch";
$reserves_control_branch = $item->homebranch;
}
elsif ( $controlbranch eq "PatronLibrary" ) {
} elsif ( $controlbranch eq "PatronLibrary" ) {
$branchfield = "borrowers.branchcode";
$reserves_control_branch = $patron->branchcode;
}
# we retrieve rights
if (
my $reservesallowed = Koha::CirculationRules->get_effective_rule({
my $reservesallowed = Koha::CirculationRules->get_effective_rule(
{
itemtype => $item->effective_itemtype,
categorycode => $patron->categorycode,
branchcode => $reserves_control_branch,
rule_name => 'reservesallowed',
})
) {
}
)
)
{
$ruleitemtype = $reservesallowed->itemtype;
$allowedreserves = $reservesallowed->rule_value // 0; #undefined is 0, blank is unlimited
}
else {
} else {
$ruleitemtype = undef;
}
my $rights = Koha::CirculationRules->get_effective_rules({
my $rights = Koha::CirculationRules->get_effective_rules(
{
categorycode => $patron->categorycode,
itemtype => $item->effective_itemtype,
branchcode => $reserves_control_branch,
rules => [ 'holds_per_record', 'holds_per_day' ]
});
}
);
my $holds_per_record = $rights->{holds_per_record} // 1;
my $holds_per_day = $rights->{holds_per_day};
@ -555,17 +569,20 @@ sub CanItemBeReserved {
biblionumber => $item->biblionumber,
};
my $holds = Koha::Holds->search($search_params);
return _cache { status => "tooManyHoldsForThisRecord", limit => $holds_per_record } if $holds->count() >= $holds_per_record;
return _cache { status => "tooManyHoldsForThisRecord", limit => $holds_per_record }
if $holds->count() >= $holds_per_record;
}
}
if (!$params->{ignore_hold_counts} && defined $holds_per_day && $holds_per_day ne '')
if ( !$params->{ignore_hold_counts} && defined $holds_per_day && $holds_per_day ne '' ) {
my $today_holds = Koha::Holds->search(
{
my $today_holds = Koha::Holds->search({
borrowernumber => $patron->borrowernumber,
reservedate => dt_from_string->date
});
return _cache { status => 'tooManyReservesToday', limit => $holds_per_day } if $today_holds->count() >= $holds_per_day;
}
);
return _cache { status => 'tooManyReservesToday', limit => $holds_per_day }
if $today_holds->count() >= $holds_per_day;
}
# we check if it's ok or not
@ -574,6 +591,7 @@ sub CanItemBeReserved {
return _cache { status => 'noReservesAllowed' };
}
if ( !$params->{ignore_hold_counts} ) {
# we retrieve count
my $querycount = q{
SELECT count(*) AS count
@ -593,8 +611,7 @@ sub CanItemBeReserved {
AND ( COALESCE( items.itype, biblioitems.itemtype ) = ?
OR reserves.itemtype = ? )
};
}
else {
} else {
$querycount .= q{
AND ( biblioitems.itemtype = ?
OR reserves.itemtype = ? )
@ -606,8 +623,7 @@ sub CanItemBeReserved {
if ( defined $ruleitemtype ) {
$sthcount->execute( $patron->borrowernumber, $reserves_control_branch, $ruleitemtype, $ruleitemtype );
}
else {
} else {
$sthcount->execute( $patron->borrowernumber, $reserves_control_branch );
}
@ -616,7 +632,8 @@ sub CanItemBeReserved {
$reservecount = $rowcount->{count};
}
return _cache { status => 'tooManyReserves', limit => $allowedreserves } if $reservecount >= $allowedreserves;
return _cache { status => 'tooManyReserves', limit => $allowedreserves }
if $reservecount >= $allowedreserves;
}
}
@ -629,17 +646,13 @@ sub CanItemBeReserved {
}
);
if ( !$params->{ignore_hold_counts} && $rule && defined( $rule->rule_value ) && $rule->rule_value ne '' ) {
my $total_holds_count = Koha::Holds->search(
{
borrowernumber => $patron->borrowernumber
}
)->count();
my $total_holds_count = Koha::Holds->search( { borrowernumber => $patron->borrowernumber } )->count();
return _cache { status => 'tooManyReserves', limit => $rule->rule_value} if $total_holds_count >= $rule->rule_value;
return _cache { status => 'tooManyReserves', limit => $rule->rule_value }
if $total_holds_count >= $rule->rule_value;
}
my $branchitemrule =
C4::Circulation::GetBranchItemRule( $reserves_control_branch, $item->effective_itemtype );
my $branchitemrule = C4::Circulation::GetBranchItemRule( $reserves_control_branch, $item->effective_itemtype );
if ( $branchitemrule->{holdallowed} eq 'not_allowed' ) {
return _cache { status => 'notReservable' };
@ -653,15 +666,19 @@ sub CanItemBeReserved {
my $item_library = Koha::Libraries->find( { branchcode => $item->homebranch } );
if ( $branchitemrule->{holdallowed} eq 'from_local_hold_group' ) {
if($patron->branchcode ne $item->homebranch && !$item_library->validate_hold_sibling( {branchcode => $patron->branchcode} )) {
if ( $patron->branchcode ne $item->homebranch
&& !$item_library->validate_hold_sibling( { branchcode => $patron->branchcode } ) )
{
return _cache { status => 'branchNotInHoldGroup' };
}
}
if ($pickup_branchcode) {
my $destination = Koha::Libraries->find({
my $destination = Koha::Libraries->find(
{
branchcode => $pickup_branchcode,
});
}
);
unless ($destination) {
return _cache { status => 'libraryNotFound' };
@ -672,10 +689,15 @@ sub CanItemBeReserved {
unless ( $item->can_be_transferred( { to => $destination } ) ) {
return _cache { status => 'cannotBeTransferred' };
}
if ($branchitemrule->{hold_fulfillment_policy} eq 'holdgroup' && !$item_library->validate_hold_sibling( {branchcode => $pickup_branchcode} )) {
if ( $branchitemrule->{hold_fulfillment_policy} eq 'holdgroup'
&& !$item_library->validate_hold_sibling( { branchcode => $pickup_branchcode } ) )
{
return _cache { status => 'pickupNotInHoldGroup' };
}
if ($branchitemrule->{hold_fulfillment_policy} eq 'patrongroup' && !Koha::Libraries->find({branchcode => $patron->branchcode})->validate_hold_sibling({branchcode => $pickup_branchcode})) {
if ( $branchitemrule->{hold_fulfillment_policy} eq 'patrongroup'
&& !Koha::Libraries->find( { branchcode => $patron->branchcode } )
->validate_hold_sibling( { branchcode => $pickup_branchcode } ) )
{
return _cache { status => 'pickupNotInHoldGroup' };
}
}
@ -736,17 +758,23 @@ SELECT COUNT(*) FROM reserves WHERE biblionumber=? AND borrowernumber<>?
$fee += 0;
my $hold_fee_mode = C4::Context->preference('HoldFeeMode') || 'not_always';
if ( $fee and $fee > 0 and $hold_fee_mode eq 'not_always' ) {
# This is a reconstruction of the old code:
# Compare number of items with items issued, and optionally check holds
# If not all items are issued and there are no holds: charge no fee
# NOTE: Lost, damaged, not-for-loan, etc. are just ignored here
my ( $notissued, $reserved );
( $notissued ) = $dbh->selectrow_array( $issue_qry, undef,
( $biblionumber ) );
($notissued) = $dbh->selectrow_array(
$issue_qry, undef,
($biblionumber)
);
if ( $notissued == 0 ) {
# all items are issued
( $reserved ) = $dbh->selectrow_array( $holds_qry, undef,
( $biblionumber, $borrowernumber ) );
($reserved) = $dbh->selectrow_array(
$holds_qry, undef,
( $biblionumber, $borrowernumber )
);
$fee = 0 if $reserved == 0;
} else {
$fee = 0;
@ -821,6 +849,7 @@ table in the Koha database.
sub CheckReserves {
my ( $item, $lookahead_days, $ignore_borrowers ) = @_;
# note: we get the itemnumber because we might have started w/ just the barcode. Now we know for sure we have it.
return unless $item; # bail if we got nothing.
@ -839,8 +868,7 @@ sub CheckReserves {
if ($item_type) {
return if Koha::ItemTypes->find($item_type)->notforloan;
}
}
else {
} else {
return;
}
@ -873,36 +901,46 @@ sub CheckReserves {
if ($LocalHoldsPriority) {
$patron = Koha::Patrons->find( $res->{borrowernumber} );
unless ($item->exclude_from_local_holds_priority || $patron->category->exclude_from_local_holds_priority) {
my $local_holds_priority_item_branchcode =
$item->$LocalHoldsPriorityItemControl;
unless ( $item->exclude_from_local_holds_priority
|| $patron->category->exclude_from_local_holds_priority )
{
my $local_holds_priority_item_branchcode = $item->$LocalHoldsPriorityItemControl;
my $local_holds_priority_patron_branchcode =
( $LocalHoldsPriorityPatronControl eq 'PickupLibrary' )
? $res->{branchcode}
: ( $LocalHoldsPriorityPatronControl eq 'HomeLibrary' )
? $patron->branchcode
( $LocalHoldsPriorityPatronControl eq 'PickupLibrary' ) ? $res->{branchcode}
: ( $LocalHoldsPriorityPatronControl eq 'HomeLibrary' ) ? $patron->branchcode
: undef;
$local_hold_match =
$local_holds_priority_item_branchcode eq
$local_holds_priority_patron_branchcode;
$local_holds_priority_item_branchcode eq $local_holds_priority_patron_branchcode;
}
}
# See if this item is more important than what we've got so far
if ( ( $res->{'priority'} && $res->{'priority'} < $priority ) || $local_hold_match ) {
next if $res->{item_group_id} && ( !$item->item_group || $item->item_group->id != $res->{item_group_id} );
next
if $res->{item_group_id}
&& ( !$item->item_group || $item->item_group->id != $res->{item_group_id} );
next if $res->{itemtype} && $res->{itemtype} ne $item->effective_itemtype;
$patron //= Koha::Patrons->find( $res->{borrowernumber} );
my $branch = Koha::Policy::Holds->holds_control_library( $item, $patron );
my $branchitemrule = C4::Circulation::GetBranchItemRule( $branch, $item->effective_itemtype );
next if ( $branchitemrule->{'holdallowed'} eq 'not_allowed' );
next if (($branchitemrule->{'holdallowed'} eq 'from_home_library') && ($item->homebranch ne $patron->branchcode));
next
if ( ( $branchitemrule->{'holdallowed'} eq 'from_home_library' )
&& ( $item->homebranch ne $patron->branchcode ) );
my $library = Koha::Libraries->find( { branchcode => $item->homebranch } );
next if (($branchitemrule->{'holdallowed'} eq 'from_local_hold_group') && (!$library->validate_hold_sibling({branchcode => $patron->branchcode}) ));
next
if ( ( $branchitemrule->{'holdallowed'} eq 'from_local_hold_group' )
&& ( !$library->validate_hold_sibling( { branchcode => $patron->branchcode } ) ) );
my $hold_fulfillment_policy = $branchitemrule->{hold_fulfillment_policy};
next if ( ($hold_fulfillment_policy eq 'holdgroup') && (!$library->validate_hold_sibling({branchcode => $res->{branchcode}})) );
next if ( ($hold_fulfillment_policy eq 'homebranch') && ($res->{branchcode} ne $item->$hold_fulfillment_policy) );
next if ( ($hold_fulfillment_policy eq 'holdingbranch') && ($res->{branchcode} ne $item->$hold_fulfillment_policy) );
next
if ( ( $hold_fulfillment_policy eq 'holdgroup' )
&& ( !$library->validate_hold_sibling( { branchcode => $res->{branchcode} } ) ) );
next
if ( ( $hold_fulfillment_policy eq 'homebranch' )
&& ( $res->{branchcode} ne $item->$hold_fulfillment_policy ) );
next
if ( ( $hold_fulfillment_policy eq 'holdingbranch' )
&& ( $res->{branchcode} ne $item->$hold_fulfillment_policy ) );
next unless $item->can_be_transferred( { to => Koha::Libraries->find( $res->{branchcode} ) } );
$priority = $res->{'priority'};
$highest = $res;
@ -1038,7 +1076,8 @@ sub ModReserve {
my $hold;
unless ($reserve_id) {
my $holds = Koha::Holds->search({ biblionumber => $biblionumber, borrowernumber => $borrowernumber, itemnumber => $itemnumber });
my $holds = Koha::Holds->search(
{ biblionumber => $biblionumber, borrowernumber => $borrowernumber, itemnumber => $itemnumber } );
return unless $holds->count; # FIXME Should raise an exception
$hold = $holds->next;
$reserve_id = $hold->reserve_id;
@ -1053,16 +1092,14 @@ sub ModReserve {
if ( $rank eq "del" ) {
$hold->cancel( { cancellation_reason => $cancellation_reason } );
}
elsif ($hold->found && $hold->priority eq '0' && $date) {
} elsif ( $hold->found && $hold->priority eq '0' && $date ) {
# The only column that can be updated for a found hold is the expiration date
$hold->expirationdate($date)->store();
logaction( 'HOLDS', 'MODIFY', $hold->reserve_id, $hold, undef, $original )
if C4::Context->preference('HoldsLog');
}
elsif ($rank =~ /^\d+/ and $rank > 0) {
} elsif ( $rank =~ /^\d+/ and $rank > 0 ) {
my $properties = {
priority => $rank,
branchcode => $branchcode,
@ -1083,6 +1120,7 @@ sub ModReserve {
if ($suspend_until) {
$hold->suspend_hold($suspend_until);
} else {
# If the hold is suspended leave the hold suspended, but convert it to an indefinite hold.
# If the hold is not suspended, this does nothing.
$hold->set( { suspend_until => undef } )->store();
@ -1114,14 +1152,17 @@ sub ModReserveStatus {
my ( $itemnumber, $newstatus ) = @_;
my $dbh = C4::Context->dbh;
my $query = "UPDATE reserves SET found = ?, waitingdate = NOW() WHERE itemnumber = ? AND found IS NULL AND priority = 0";
my $query =
"UPDATE reserves SET found = ?, waitingdate = NOW() WHERE itemnumber = ? AND found IS NULL AND priority = 0";
my $sth_set = $dbh->prepare($query);
$sth_set->execute( $newstatus, $itemnumber );
my $item = Koha::Items->find($itemnumber);
if ( $item->location && $item->location eq 'CART'
if ( $item->location
&& $item->location eq 'CART'
&& ( !$item->permanent_location || $item->permanent_location ne 'CART' )
&& $newstatus ) {
&& $newstatus )
{
CartToShelf($itemnumber);
}
}
@ -1157,10 +1198,13 @@ sub ModReserveAffect {
# waiting in order to not send duplicate hold filled notifications
my $hold;
# Find hold by id if we have it
$hold = Koha::Holds->find($reserve_id) if $reserve_id;
# Find item level hold for this item if there is one
$hold ||= Koha::Holds->search( { borrowernumber => $borrowernumber, itemnumber => $itemnumber } )->next();
# Find record level hold if there is no item level hold
$hold ||= Koha::Holds->search( { borrowernumber => $borrowernumber, biblionumber => $biblionumber } )->next();
@ -1176,11 +1220,13 @@ sub ModReserveAffect {
$hold->set_transfer();
} elsif ( C4::Context->preference('HoldsNeedProcessingSIP')
&& C4::Context->interface eq 'sip'
&& !$already_on_shelf) {
&& !$already_on_shelf )
{
$hold->set_processing();
} else {
$hold->set_waiting($desk_id);
_koha_notify_reserve( $hold->reserve_id ) unless $already_on_shelf;
# Complete transfer if one exists
my $transfer = $hold->item->get_transfer;
$transfer->receive if $transfer;
@ -1190,12 +1236,15 @@ sub ModReserveAffect {
_FixPriority( { biblionumber => $biblionumber } );
my $item = Koha::Items->find($itemnumber);
if ( $item->location && $item->location eq 'CART'
&& ( !$item->permanent_location || $item->permanent_location ne 'CART' ) ) {
if ( $item->location
&& $item->location eq 'CART'
&& ( !$item->permanent_location || $item->permanent_location ne 'CART' ) )
{
CartToShelf($itemnumber);
}
my $std = $dbh->prepare(q{
my $std = $dbh->prepare(
q{
DELETE q, t
FROM tmp_holdsqueue q
INNER JOIN hold_fill_targets t
@ -1205,7 +1254,8 @@ sub ModReserveAffect {
AND q.item_level_request = t.item_level_request
AND q.holdingbranch = t.source_branchcode
WHERE t.reserve_id = ?
});
}
);
$std->execute( $hold->reserve_id );
logaction( 'HOLDS', 'MODIFY', $hold->reserve_id, $hold, undef, $original )
@ -1239,8 +1289,7 @@ sub ModReserveCancelAll {
if ($nextreservinfo) {
if ( $item->holdingbranch ne $nextreservinfo->{'branchcode'} ) {
$messages->{'transfert'} = $nextreservinfo->{'branchcode'};
}
else {
} else {
$messages->{'waiting'} = 1;
}
}
@ -1268,6 +1317,7 @@ sub ModReserveMinusPriority {
";
my $sth_upd = $dbh->prepare($query);
$sth_upd->execute( $itemnumber, $reserve_id );
# second step update all others reserves
_FixPriority( { reserve_id => $reserve_id, rank => '0' } );
}
@ -1307,6 +1357,7 @@ sub IsAvailableForItemLevelRequest {
my $pickup_branchcode = shift;
my $dbh = C4::Context->dbh;
# must check the notforloan setting of the itemtype
# FIXME - a lot of places in the code do this
# or something similar - need to be
@ -1316,12 +1367,13 @@ sub IsAvailableForItemLevelRequest {
unless defined $itemtype;
my $notforloan_per_itemtype = Koha::ItemTypes->find($itemtype)->notforloan;
return 0 if
$notforloan_per_itemtype ||
$item->itemlost ||
$item->notforloan > 0 || # item with negative or zero notforloan value is holdable
$item->withdrawn ||
($item->damaged && !C4::Context->preference('AllowHoldsOnDamagedItems'));
return 0
if $notforloan_per_itemtype
|| $item->itemlost
|| $item->notforloan > 0
|| # item with negative or zero notforloan value is holdable
$item->withdrawn
|| ( $item->damaged && !C4::Context->preference('AllowHoldsOnDamagedItems') );
if ($pickup_branchcode) {
my $destination = Koha::Libraries->find($pickup_branchcode);
@ -1329,10 +1381,11 @@ sub IsAvailableForItemLevelRequest {
return 0 unless $destination->pickup_location;
return 0 unless $item->can_be_transferred( { to => $destination } );
my $reserves_control_branch = Koha::Policy::Holds->holds_control_library( $item, $patron );
my $branchitemrule =
C4::Circulation::GetBranchItemRule( $reserves_control_branch, $item->itype );
my $branchitemrule = C4::Circulation::GetBranchItemRule( $reserves_control_branch, $item->itype );
my $home_library = Koha::Libraries->find( { branchcode => $item->homebranch } );
return 0 unless $branchitemrule->{hold_fulfillment_policy} ne 'holdgroup' || $home_library->validate_hold_sibling( {branchcode => $pickup_branchcode} );
return 0
unless $branchitemrule->{hold_fulfillment_policy} ne 'holdgroup'
|| $home_library->validate_hold_sibling( { branchcode => $pickup_branchcode } );
}
my $on_shelf_holds = Koha::CirculationRules->get_onshelfholds_policy( { item => $item, patron => $patron } );
@ -1378,8 +1431,7 @@ sub ItemsAnyAvailableAndNotRestricted {
foreach my $i (@items) {
my $reserves_control_branch = Koha::Policy::Holds->holds_control_library( $i, $param->{patron} );
my $branchitemrule =
C4::Circulation::GetBranchItemRule( $reserves_control_branch, $i->itype );
my $branchitemrule = C4::Circulation::GetBranchItemRule( $reserves_control_branch, $i->itype );
my $item_library = Koha::Libraries->find( { branchcode => $i->homebranch } );
# we can return (end the loop) when first one found:
@ -1393,7 +1445,8 @@ sub ItemsAnyAvailableAndNotRestricted {
&& !C4::Context->preference('AllowHoldsOnDamagedItems') )
|| Koha::ItemTypes->find( $i->effective_itemtype() )->notforloan
|| $branchitemrule->{holdallowed} eq 'from_home_library' && $param->{patron}->branchcode ne $i->homebranch
|| $branchitemrule->{holdallowed} eq 'from_local_hold_group' && ! $item_library->validate_hold_sibling( { branchcode => $param->{patron}->branchcode } )
|| $branchitemrule->{holdallowed} eq 'from_local_hold_group'
&& !$item_library->validate_hold_sibling( { branchcode => $param->{patron}->branchcode } )
|| CanItemBeReserved( $param->{patron}, $i )->{status} ne 'OK';
}
@ -1416,27 +1469,26 @@ sub AlterPriority {
return unless $hold;
if ( $hold->cancellationdate ) {
warn "I cannot alter the priority for reserve_id $reserve_id, the reserve has been cancelled (" . $hold->cancellationdate . ')';
warn "I cannot alter the priority for reserve_id $reserve_id, the reserve has been cancelled ("
. $hold->cancellationdate . ')';
return;
}
if ( $where eq 'up' ) {
return unless $prev_priority;
_FixPriority({ reserve_id => $reserve_id, rank => $prev_priority })
_FixPriority( { reserve_id => $reserve_id, rank => $prev_priority } );
} elsif ( $where eq 'down' ) {
return unless $next_priority;
_FixPriority({ reserve_id => $reserve_id, rank => $next_priority })
_FixPriority( { reserve_id => $reserve_id, rank => $next_priority } );
} elsif ( $where eq 'top' ) {
_FixPriority({ reserve_id => $reserve_id, rank => $first_priority })
_FixPriority( { reserve_id => $reserve_id, rank => $first_priority } );
} elsif ( $where eq 'bottom' ) {
_FixPriority( { reserve_id => $reserve_id, rank => $last_priority } );
}
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
{
biblio_ids => [ $hold->biblionumber ]
}
) if C4::Context->preference('RealTimeHoldsQueue');
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue( { biblio_ids => [ $hold->biblionumber ] } )
if C4::Context->preference('RealTimeHoldsQueue');
# FIXME Should return the new priority
}
@ -1494,13 +1546,11 @@ sub SuspendAll {
if ($suspend) {
map { $_->suspend_hold($suspend_until) } @holds;
}
else {
} else {
map { $_->resume() } @holds;
}
}
=head2 _FixPriority
_FixPriority({
@ -1549,6 +1599,7 @@ sub _FixPriority {
if ($reserve_id) {
$hold = Koha::Holds->find($reserve_id);
if ( !defined $hold ) {
# may have already been checked out and hold fulfilled
require Koha::Old::Holds;
$hold = Koha::Old::Holds->find($reserve_id);
@ -1562,8 +1613,7 @@ sub _FixPriority {
if ( $rank eq "del" ) { # FIXME will crash if called without $hold
$hold->cancel;
}
elsif ( $reserve_id && ( $rank eq "W" || $rank eq "0" ) ) {
} elsif ( $reserve_id && ( $rank eq "W" || $rank eq "0" ) ) {
# make sure priority for waiting or in-transit items is 0
my $query = "
@ -1625,14 +1675,17 @@ sub _FixPriority {
}
unless ($ignoreSetLowestRank) {
$sth = $dbh->prepare( "SELECT reserve_id FROM reserves WHERE lowestPriority = 1 AND biblionumber = ? ORDER BY priority" );
$sth = $dbh->prepare(
"SELECT reserve_id FROM reserves WHERE lowestPriority = 1 AND biblionumber = ? ORDER BY priority");
$sth->execute($biblionumber);
while ( my $res = $sth->fetchrow_hashref() ) {
_FixPriority({
_FixPriority(
{
reserve_id => $res->{'reserve_id'},
rank => '999999',
ignoreSetLowestRank => 1
});
}
);
}
}
}
@ -1771,10 +1824,12 @@ sub _koha_notify_reserve {
# Try to get the borrower's email address
my $to_address = $patron->notice_email_address;
my $messagingprefs = C4::Members::Messaging::GetMessagingPreferences( {
my $messagingprefs = C4::Members::Messaging::GetMessagingPreferences(
{
borrowernumber => $borrowernumber,
message_name => 'Hold_Filled'
} );
}
);
my $library = Koha::Libraries->find( $hold->branchcode );
my $from_email_address = $library->from_email_address;
@ -1794,7 +1849,8 @@ sub _koha_notify_reserve {
},
);
my $notification_sent = 0; #Keeping track if a Hold_filled message is sent. If no message can be sent, then default to a print message.
my $notification_sent =
0; #Keeping track if a Hold_filled message is sent. If no message can be sent, then default to a print message.
my $do_not_lock = ( exists $ENV{_} && $ENV{_} =~ m|prove| ) || $ENV{KOHA_TESTING};
my $send_notification = sub {
my ( $mtt, $letter_code, $wants_digest ) = (@_);
@ -1833,16 +1889,20 @@ sub _koha_notify_reserve {
};
while ( my ( $mtt, $letter_code ) = each %{ $messagingprefs->{transports} } ) {
next if (
next
if (
( $mtt eq 'email' and not $to_address ) # No email address
or ( $mtt eq 'sms' and not $patron->smsalertnumber ) # No SMS number
or ( $mtt eq 'itiva' and C4::Context->preference('TalkingTechItivaPhoneNotification') ) # Notice is handled by TalkingTech_itiva_outbound.pl
or ( $mtt eq 'itiva'
and C4::Context->preference('TalkingTechItivaPhoneNotification')
) # Notice is handled by TalkingTech_itiva_outbound.pl
or ( $mtt eq 'phone' and not $patron->phone ) # No phone number to call
);
&$send_notification( $mtt, $letter_code, $messagingprefs->{wants_digest} );
$notification_sent++;
}
#Making sure that a print notification is sent if no other transport types can be utilized.
if ( !$notification_sent ) {
&$send_notification( 'print', 'HOLD' );
@ -1879,8 +1939,7 @@ sub _koha_notify_hold_changed {
return unless $letter;
my $email =
C4::Context->preference('ExpireReservesAutoFillEmail')
my $email = C4::Context->preference('ExpireReservesAutoFillEmail')
|| $library->inbound_email_address;
C4::Letters::EnqueueLetter(
@ -1920,6 +1979,7 @@ sub _ShiftPriority {
my $sth = $dbh->prepare($query);
$sth->execute( $biblio, $new_priority );
my $min_priority = $sth->fetchrow;
# if no such matches are found, $new_priority remains as original value
$new_priority = $min_priority if ($min_priority);
@ -1933,7 +1993,8 @@ sub _ShiftPriority {
my $sth_update = $dbh->prepare($query);
# Select all reserves for the biblio with priority greater than $new_priority, and order greatest to least
$query = "SELECT borrowernumber, reservedate FROM reserves WHERE priority >= ? AND biblionumber = ? ORDER BY priority DESC";
$query =
"SELECT borrowernumber, reservedate FROM reserves WHERE priority >= ? AND biblionumber = ? ORDER BY priority DESC";
$sth = $dbh->prepare($query);
$sth->execute( $new_priority, $biblio );
while ( my $row = $sth->fetchrow_hashref ) {
@ -1967,28 +2028,29 @@ sub MoveReserve {
if ( $res->{borrowernumber} == $borrowernumber ) {
my $hold = Koha::Holds->find( $res->{reserve_id} );
$hold->fill( { item_id => $itemnumber } );
}
else {
} else {
# warn "Reserved";
# The item is reserved by someone else.
# Find this item in the reserves
my $borr_res = Koha::Holds->search({
my $borr_res = Koha::Holds->search(
{
borrowernumber => $borrowernumber,
biblionumber => $biblionumber,
},{
order_by => 'priority'
})->next();
},
{ order_by => 'priority' }
)->next();
if ($borr_res) {
# The item is reserved by the current patron
$borr_res->fill( { item_id => $itemnumber } );
}
if ( $cancelreserve eq 'revert' ) { ## Revert waiting reserve to priority 1
RevertWaitingStatus( { itemnumber => $itemnumber } );
}
elsif ( $cancelreserve eq 'cancel' || $cancelreserve ) { # cancel reserves on this item
} elsif ( $cancelreserve eq 'cancel' || $cancelreserve ) { # cancel reserves on this item
my $hold = Koha::Holds->find( $res->{reserve_id} );
$hold->cancel;
}
@ -2005,15 +2067,12 @@ This shifts the holds from C<$from_biblio> to C<$to_biblio> and reorders them by
sub MergeHolds {
my ( $dbh, $to_biblio, $from_biblio ) = @_;
my $sth = $dbh->prepare(
"SELECT count(*) as reserve_count FROM reserves WHERE biblionumber = ?"
);
my $sth = $dbh->prepare("SELECT count(*) as reserve_count FROM reserves WHERE biblionumber = ?");
$sth->execute($from_biblio);
if ( my $data = $sth->fetchrow_hashref() ) {
# holds exist on old record, if not we don't need to do anything
$sth = $dbh->prepare(
"UPDATE reserves SET biblionumber = ? WHERE biblionumber = ?");
$sth = $dbh->prepare("UPDATE reserves SET biblionumber = ? WHERE biblionumber = ?");
$sth->execute( $to_biblio, $from_biblio );
# Reorder by date
@ -2092,12 +2151,8 @@ sub RevertWaitingStatus {
_FixPriority( { biblionumber => $hold->biblionumber } );
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
{
biblio_ids => [ $hold->biblionumber ]
}
) if C4::Context->preference('RealTimeHoldsQueue');
Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue( { biblio_ids => [ $hold->biblionumber ] } )
if C4::Context->preference('RealTimeHoldsQueue');
return $hold;
}
@ -2184,11 +2239,11 @@ sub CalculatePriority {
AND priority > 0
AND (found IS NULL OR found = '')
};
#skip found==W or found==T or found==P (waiting, transit or processing holds)
if ($resdate) {
$sql .= ' AND ( reservedate <= ? )';
}
else {
} else {
$sql .= ' AND ( reservedate < NOW() )';
}
my $dbh = C4::Context->dbh();
@ -2231,12 +2286,14 @@ sub GetMaxPatronHoldsForRecord {
$branchcode = $item->homebranch if ( $controlbranch eq "ItemHomeLibrary" );
my $rule = Koha::CirculationRules->get_effective_rule({
my $rule = Koha::CirculationRules->get_effective_rule(
{
categorycode => $categorycode,
itemtype => $itemtype,
branchcode => $branchcode,
rule_name => 'holds_per_record'
});
}
);
my $holds_per_record = $rule ? $rule->rule_value : 0;
$max = $holds_per_record if $holds_per_record > $max;
}

246
C4/Ris.pm
View File

@ -37,7 +37,6 @@ package C4::Ris;
## comparing UKMARC to MARC21 found at:
## www.bl.uk/services/bibliographic/marcchange.pdf
# Modified 2008 by BibLibre for Koha
# Modified 2011 by Catalyst
# Modified 2011 by Equinox Software, Inc.
@ -68,7 +67,6 @@ use vars qw(@ISA @EXPORT);
use Koha::SimpleMARC qw( read_field );
@ISA = qw(Exporter);
# only export API methods
@ -108,8 +106,7 @@ sub marc2ris {
if ( $intype eq "marc21" ) {
if ( $leader =~ /^.{9}a/ ) {
print "<marc>---\r\n<marc>UTF-8 data\r\n" if $marcprint;
}
else {
} else {
print "<marc>---\r\n<marc>MARC-8 data\r\n" if $marcprint;
}
}
@ -124,12 +121,10 @@ sub marc2ris {
my ($type) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
if ($type) {
print "TY - $type\r\n";
}
else {
} else {
&print_typetag($leader);
}
}
else {
} else {
&print_typetag($leader);
}
@ -139,8 +134,7 @@ sub marc2ris {
if ( $intype eq "unimarc" ) {
## Fields 700, 701, and 702 can contain author names
@author_fields = ( $record->field('700'), $record->field('701'), $record->field('702') );
}
else { ## marc21, ukmarc
} else { ## marc21, ukmarc
## Field 100 sometimes carries main author
## Field(s) 700 carry added entries - personal names
@author_fields = ( $record->field('100'), $record->field('700') );
@ -163,9 +157,11 @@ sub marc2ris {
if ( $intype eq "unimarc" ) {
## Fields 710, 711, and 712 can carry corporate names
## Field(s) 720, 721, 722, 730 have additional candidates
@editor_fields = ($record->field('710'), $record->field('711'), $record->field('712'), $record->field('720'), $record->field('721'), $record->field('722'), $record->field('730'));
}
else { ## marc21, ukmarc
@editor_fields = (
$record->field('710'), $record->field('711'), $record->field('712'), $record->field('720'),
$record->field('721'), $record->field('722'), $record->field('730')
);
} else { ## marc21, ukmarc
## Fields 110 and 111 carry the main entries - corporate name and
## meeting name, respectively
## Field(s) 710, 711 carry added entries - personal names
@ -183,16 +179,14 @@ sub marc2ris {
## get info from the title field
if ( $intype eq "unimarc" ) {
&print_title( $record->field('200') );
}
else { ## marc21, ukmarc
} else { ## marc21, ukmarc
&print_title( $record->field('245') );
}
## series title
if ( $intype eq "unimarc" ) {
&print_stitle( $record->field('225') );
}
else { ## marc21, ukmarc
} else { ## marc21, ukmarc
&print_stitle( $record->field('490') );
}
@ -200,13 +194,11 @@ sub marc2ris {
if ( $intype eq "unimarc" ) {
&print_isbn( $record->field('010') );
&print_issn( $record->field('011') );
}
elsif ($intype eq "ukmarc") {
} elsif ( $intype eq "ukmarc" ) {
&print_isbn( $record->field('021') );
## this is just an assumption
&print_issn( $record->field('022') );
}
else { ## assume marc21
} else { ## assume marc21
&print_isbn( $record->field('020') );
&print_issn( $record->field('022') );
}
@ -220,12 +212,10 @@ sub marc2ris {
## publication info
if ( $intype eq "unimarc" ) {
&print_pubinfo( $record->field('210') );
}
else { ## marc21, ukmarc
} else { ## marc21, ukmarc
if ( $record->field('264') ) {
&print_pubinfo( $record->field('264') );
}
else {
} else {
&print_pubinfo( $record->field('260') );
}
}
@ -234,9 +224,13 @@ sub marc2ris {
my @field_list;
if ( $intype eq "unimarc" ) {
@field_list = ('600', '601', '602', '604', '605', '606','607', '608', '610', '615', '620', '660', '661', '670', '675', '676', '680', '686');
@field_list = (
'600', '601', '602', '604', '605', '606', '607', '608', '610', '615', '620', '660', '661', '670', '675',
'676', '680', '686'
);
} elsif ( $intype eq "ukmarc" ) {
@field_list = ('600', '610', '611', '630', '650', '651','653', '655', '660', '661', '668', '690', '691', '692', '695');
@field_list =
( '600', '610', '611', '630', '650', '651', '653', '655', '660', '661', '668', '690', '691', '692', '695' );
} else { ## assume marc21
@field_list = ( '600', '610', '611', '630', '650', '651', '653', '654', '655', '656', '657', '658' );
}
@ -260,17 +254,29 @@ sub marc2ris {
## these fields have notes candidates
if ( $intype eq "unimarc" ) {
foreach ('300', '301', '302', '303', '304', '305', '306', '307', '308', '310', '311', '312', '313', '314', '315', '316', '317', '318', '320', '321', '322', '323', '324', '325', '326', '327', '328', '332', '333', '336', '337', '345') {
foreach (
'300', '301', '302', '303', '304', '305', '306', '307', '308', '310', '311', '312', '313', '314',
'315', '316', '317', '318', '320', '321', '322', '323', '324', '325', '326', '327', '328', '332', '333',
'336', '337', '345'
)
{
&pool_subx( \@notepool, $_, $record->field($_) );
}
}
elsif ($intype eq "ukmarc") {
foreach ('500', '501', '502', '503', '504', '505', '506', '508', '514', '515', '516', '521', '524', '525', '528', '530', '531', '532', '533', '534', '535', '537', '538', '540', '541', '542', '544', '554', '555', '556', '557', '561', '563', '580', '583', '584', '586') {
} elsif ( $intype eq "ukmarc" ) {
foreach (
'500', '501', '502', '503', '504', '505', '506', '508', '514', '515', '516', '521', '524', '525',
'528', '530', '531', '532', '533', '534', '535', '537', '538', '540', '541', '542', '544', '554', '555',
'556', '557', '561', '563', '580', '583', '584', '586'
)
{
&pool_subx( \@notepool, $_, $record->field($_) );
}
}
else { ## assume marc21
foreach ('500', '501', '502', '504', '505', '506', '507', '508', '510', '511', '513', '514', '515', '516', '518', '521', '522', '524', '525', '526', '530', '533', '534', '535') {
} else { ## assume marc21
foreach (
'500', '501', '502', '504', '505', '506', '507', '508', '510', '511', '513', '514', '515', '516',
'518', '521', '522', '524', '525', '526', '530', '533', '534', '535'
)
{
&pool_subx( \@notepool, $_, $record->field($_) );
}
}
@ -284,11 +290,9 @@ sub marc2ris {
## 320/520 have the abstract
if ( $intype eq "unimarc" ) {
&print_abstract( $record->field('320') );
}
elsif ($intype eq "ukmarc") {
} elsif ( $intype eq "ukmarc" ) {
&print_abstract( $record->field('512'), $record->field('513') );
}
else { ## assume marc21
} else { ## assume marc21
&print_abstract( $record->field('520') );
}
@ -327,7 +331,6 @@ sub marc2ris {
}
##********************************************************************
## print_typetag(): prints the first line of a RIS dataset including
## the preceding newline
@ -373,11 +376,9 @@ sub print_typetag {
);
## The type of a MARC record is found at position 06 of the leader
my $typeofrecord = defined($leader) && length $leader >=6 ?
substr($leader, 6, 1): undef;
my $typeofrecord = defined($leader) && length $leader >= 6 ? substr( $leader, 6, 1 ) : undef;
## Pos 07 == Bibliographic level
my $biblevel = defined($leader) && length $leader >=7 ?
substr($leader, 7, 1): '';
my $biblevel = defined($leader) && length $leader >= 7 ? substr( $leader, 7, 1 ) : '';
## TODO: for books, field 008 positions 24-27 might have a few more
## hints
@ -387,8 +388,7 @@ sub print_typetag {
my $intype = lc($marcflavour);
if ( $intype eq "unimarc" ) {
%typehash = %unitypehash;
}
else {
} else {
%typehash = %ustypehash;
}
@ -430,11 +430,11 @@ sub normalize_author {
my ( $rawauthora, $rawauthorb, $rawauthorc, $nametype ) = @_;
if ( $nametype == 0 ) {
# ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
return $rawauthora;
}
elsif ($nametype == 1) {
} elsif ( $nametype == 1 ) {
## start munging subfield a (the real name part)
## remove spaces after separators
$rawauthora =~ s%([,.]+) *%$1%g;
@ -452,12 +452,10 @@ sub normalize_author {
## we currently ignore subfield c until someone complains
if ( length($rawauthorb) > 0 ) {
return join ", ", ( $rawauthora, $rawauthorb );
}
else {
} else {
return $rawauthora;
}
}
elsif ($nametype == 3) {
} elsif ( $nametype == 3 ) {
return $rawauthora;
}
}
@ -477,8 +475,7 @@ sub get_author {
my $intype = lc($marcflavour);
if ( $intype eq "unimarc" ) {
$indicator = 2;
}
else { ## assume marc21
} else { ## assume marc21
$indicator = 1;
}
@ -489,10 +486,15 @@ sub get_author {
print "<marc>:Author(\$h): ", $authorfield->subfield('h'), "\r\n" if $marcprint;
if ( $intype eq "ukmarc" ) {
my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
}
else {
normalize_author($authorfield->subfield('a') // '', $authorfield->subfield('b') // '', $authorfield->subfield('c') // '', $authorfield->indicator("$indicator"));
normalize_author(
$authorname, $authorfield->subfield('b'), $authorfield->subfield('c'),
$authorfield->indicator("$indicator")
);
} else {
normalize_author(
$authorfield->subfield('a') // '', $authorfield->subfield('b') // '',
$authorfield->subfield('c') // '', $authorfield->indicator("$indicator")
);
}
}
@ -506,8 +508,7 @@ sub get_editor {
if ( !$editorfield ) {
return;
}
else {
} else {
print "<marc>Editor(\$a): ", $editorfield->subfield('a'), "\r\n" if $marcprint;
print "<marc>Editor(\$b): ", $editorfield->subfield('b'), "\r\n" if $marcprint;
print "<marc>editor(\$c): ", $editorfield->subfield('c'), "\r\n" if $marcprint;
@ -525,8 +526,7 @@ sub print_title {
if ( !$titlefield ) {
print "<marc>empty title field (245)\r\n" if $marcprint;
warn("empty title field (245)") if $marcprint;
}
else {
} else {
print "<marc>Title(\$a): ", $titlefield->subfield('a'), "\r\n" if $marcprint;
print "<marc>Title(\$b): ", $titlefield->subfield('b'), "\r\n" if $marcprint;
print "<marc>Title(\$c): ", $titlefield->subfield('c'), "\r\n" if $marcprint;
@ -548,7 +548,8 @@ $clean_subtitle ||= q{};
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if ( length($clean_title) > 0
|| (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
|| ( length($clean_subtitle) > 0 && $intype ne "unimarc" ) )
{
print "TI - ", $clean_title;
## subfield $b is relevant only for marc21/ukmarc
@ -576,8 +577,7 @@ sub print_stitle {
if ( !$titlefield ) {
print "<marc>empty series title field\r\n" if $marcprint;
}
else {
} else {
print "<marc>Series title(\$a): ", $titlefield->subfield('a'), "\r\n" if $marcprint;
my $clean_title = $titlefield->subfield('a');
@ -609,8 +609,7 @@ sub print_isbn {
if ( !$isbnfield || length( $isbnfield->subfield('a') ) == 0 ) {
print "<marc>no isbn found (020\$a)\r\n" if $marcprint;
warn("no isbn found") if $marcprint;
}
else {
} else {
if ( length( $isbnfield->subfield('a') ) < 10 ) {
print "<marc>truncated isbn (020\$a)\r\n" if $marcprint;
warn("truncated isbn") if $marcprint;
@ -631,8 +630,7 @@ sub print_issn {
if ( !$issnfield || length( $issnfield->subfield('a') ) == 0 ) {
print "<marc>no issn found (022\$a)\r\n" if $marcprint;
warn("no issn found") if $marcprint;
}
else {
} else {
if ( length( $issnfield->subfield('a') ) < 9 ) {
print "<marc>truncated issn (022\$a)\r\n" if $marcprint;
warn("truncated issn") if $marcprint;
@ -666,8 +664,7 @@ sub print_loc_callno {
if ( !$callnofield || length( $callnofield->subfield('a') ) == 0 ) {
print "<marc>no LOC call number found (050\$a)\r\n" if $marcprint;
warn("no LOC call number found") if $marcprint;
}
else {
} else {
print "AV - ", $callnofield->subfield('a'), " ", $callnofield->subfield('b'), "\r\n";
}
}
@ -682,8 +679,7 @@ sub print_dewey {
if ( !$deweyfield || length( $deweyfield->subfield('a') ) == 0 ) {
print "<marc>no Dewey number found (082\$a)\r\n" if $marcprint;
warn("no Dewey number found") if $marcprint;
}
else {
} else {
print "U1 - ", $deweyfield->subfield('a'), " ", $deweyfield->subfield('2'), "\r\n";
}
}
@ -698,8 +694,7 @@ sub print_pubinfo {
if ( !$pubinfofield ) {
print "<marc>no publication information found (260/264)\r\n" if $marcprint;
warn("no publication information found") if $marcprint;
}
else {
} else {
## the following information is available in MARC21:
## $a place -> CY
## $b publisher -> PB
@ -731,8 +726,7 @@ sub print_pubinfo {
$pubsub_place = "a";
$pubsub_publisher = "c";
$pubsub_date = "d";
}
else { ## assume marc21
} else { ## assume marc21
$pubsub_place = "a";
$pubsub_publisher = "b";
$pubsub_date = "c";
@ -747,15 +741,13 @@ sub print_pubinfo {
s% *[,;:/]$%%;
## pool all occurrences in a list
push( @cities, $_ );
}
elsif (@$tuple[0] eq $pubsub_publisher) {
} elsif ( @$tuple[0] eq $pubsub_publisher ) {
## strip any trailing crap
$_ = @$tuple[1];
s% *[,;:/]$%%;
## pool all occurrences in a list
push( @publishers, $_ );
}
elsif (@$tuple[0] eq $pubsub_date) {
} elsif ( @$tuple[0] eq $pubsub_date ) {
## the dates are free-form, so we want to extract
## a four-digit year and leave the rest as
## "other info"
@ -779,8 +771,7 @@ sub print_pubinfo {
## replace all '-' in the four-digit year
## by '0'
substr( $protoyear, 0, 4 ) =~ s!-!0!g;
}
else {
} else {
## have no year info
print "<marc>no four-digit year found, use 0000\r\n" if $marcprint;
$protoyear = "0000///$protoyear";
@ -789,8 +780,7 @@ sub print_pubinfo {
if ( $pycounter == 0 && length($protoyear) ) {
print "PY - $protoyear\r\n";
}
elsif ($pycounter == 1 && length($_)) {
} elsif ( $pycounter == 1 && length($_) ) {
print "Y2 - $protoyear\r\n";
}
## else: discard
@ -817,18 +807,26 @@ sub get_keywords {
my @kw;
## a list of all possible subfields
my @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'x', 'y', 'z', '2', '3', '4');
my @subfields = (
'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'x',
'y', 'z', '2', '3', '4'
);
## loop over all 6XX fields
foreach my $kwfield (@keywords) {
if ( defined $kwfield ) {
## authornames get special treatment
if ( $fieldname eq "600" ) {
my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
my $val = normalize_author(
$kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'),
$kwfield->indicator('1')
);
push @kw, $val;
print "<marc>Field $kwfield subfield a:", $kwfield->subfield('a'), "\r\n<marc>Field $kwfield subfield b:", $kwfield->subfield('b'), "\r\n<marc>Field $kwfield subfield c:", $kwfield->subfield('c'), "\r\n" if $marcprint;
}
else {
print "<marc>Field $kwfield subfield a:", $kwfield->subfield('a'),
"\r\n<marc>Field $kwfield subfield b:", $kwfield->subfield('b'),
"\r\n<marc>Field $kwfield subfield c:", $kwfield->subfield('c'), "\r\n"
if $marcprint;
} else {
## retrieve all available subfields
my @kwsubfields = $kwfield->subfields();
@ -871,74 +869,51 @@ sub pool_subx {
if ( $fieldname eq "500" ) {
@subfields = ('a');
}
elsif ($fieldname eq "501") {
} elsif ( $fieldname eq "501" ) {
@subfields = ('a');
}
elsif ($fieldname eq "502") {
} elsif ( $fieldname eq "502" ) {
@subfields = ('a');
}
elsif ($fieldname eq "504") {
} elsif ( $fieldname eq "504" ) {
@subfields = ( 'a', 'b' );
}
elsif ($fieldname eq "505") {
} elsif ( $fieldname eq "505" ) {
@subfields = ( 'a', 'g', 'r', 't', 'u' );
}
elsif ($fieldname eq "506") {
} elsif ( $fieldname eq "506" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e' );
}
elsif ($fieldname eq "507") {
} elsif ( $fieldname eq "507" ) {
@subfields = ( 'a', 'b' );
}
elsif ($fieldname eq "508") {
} elsif ( $fieldname eq "508" ) {
@subfields = ('a');
}
elsif ($fieldname eq "510") {
} elsif ( $fieldname eq "510" ) {
@subfields = ( 'a', 'b', 'c', 'x', '3' );
}
elsif ($fieldname eq "511") {
} elsif ( $fieldname eq "511" ) {
@subfields = ('a');
}
elsif ($fieldname eq "513") {
} elsif ( $fieldname eq "513" ) {
@subfields = ( 'a', 'b' );
}
elsif ($fieldname eq "514") {
} elsif ( $fieldname eq "514" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z' );
}
elsif ($fieldname eq "515") {
} elsif ( $fieldname eq "515" ) {
@subfields = ('a');
}
elsif ($fieldname eq "516") {
} elsif ( $fieldname eq "516" ) {
@subfields = ('a');
}
elsif ($fieldname eq "518") {
} elsif ( $fieldname eq "518" ) {
@subfields = ( 'a', '3' );
}
elsif ($fieldname eq "521") {
} elsif ( $fieldname eq "521" ) {
@subfields = ( 'a', 'b', '3' );
}
elsif ($fieldname eq "522") {
} elsif ( $fieldname eq "522" ) {
@subfields = ('a');
}
elsif ($fieldname eq "524") {
} elsif ( $fieldname eq "524" ) {
@subfields = ( 'a', '2', '3' );
}
elsif ($fieldname eq "525") {
} elsif ( $fieldname eq "525" ) {
@subfields = ('a');
}
elsif ($fieldname eq "526") {
} elsif ( $fieldname eq "526" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'i', 'x', 'z', '5' );
}
elsif ($fieldname eq "530") {
} elsif ( $fieldname eq "530" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'u', '3' );
}
elsif ($fieldname eq "533") {
} elsif ( $fieldname eq "533" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3' );
}
elsif ($fieldname eq "534") {
} elsif ( $fieldname eq "534" ) {
@subfields = ( 'a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z' );
}
elsif ($fieldname eq "535") {
} elsif ( $fieldname eq "535" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'g', '3' );
}
@ -974,6 +949,7 @@ sub pool_subx {
## Arguments: list of fields (520)
##********************************************************************
sub print_abstract {
# ToDo: take care of repeatable subfields
my (@abfields) = @_;

33
C4/RotatingCollections.pm
View File

@ -31,7 +31,6 @@ use Try::Tiny qw( catch try );
use vars qw(@ISA @EXPORT);
=head1 NAME
C4::RotatingCollections - Functions for managing rotating collections
@ -131,7 +130,8 @@ sub UpdateCollection {
my ( $colId, $title, $description ) = @_;
my $schema = Koha::Database->new()->schema();
my $duplicate_titles = $schema->resultset('Collection')->count({ colTitle => $title, -not => { colId => $colId } });
my $duplicate_titles =
$schema->resultset('Collection')->count( { colTitle => $title, -not => { colId => $colId } } );
## Check for all necessary parameters
if ( !$colId ) {
@ -335,8 +335,7 @@ sub AddItemToCollection {
if ( isItemInThisCollection( $itemnumber, $colId ) ) {
return ( 0, 2, "IN_COLLECTION" );
}
elsif ( isItemInAnyCollection($itemnumber) ) {
} elsif ( isItemInAnyCollection($itemnumber) ) {
return ( 0, 3, "IN_COLLECTION_OTHER" );
}
@ -435,13 +434,15 @@ sub TransferCollection {
$sth->execute( $colBranchcode, $colId ) or return 0;
my $to_library = Koha::Libraries->find($colBranchcode);
$sth = $dbh->prepare(q{
$sth = $dbh->prepare(
q{
SELECT items.itemnumber, items.barcode FROM collections_tracking
LEFT JOIN items ON collections_tracking.itemnumber = items.itemnumber
LEFT JOIN issues ON items.itemnumber = issues.itemnumber
WHERE issues.borrowernumber IS NULL
AND collections_tracking.colId = ?
});
}
);
$sth->execute($colId) or return 0;
my $messages;
while ( my $item = $sth->fetchrow_hashref ) {
@ -454,8 +455,7 @@ sub TransferCollection {
ignore_limits => 0
}
); # Request transfer
}
catch {
} catch {
if ( $_->isa('Koha::Exceptions::Item::Transfer::InQueue') ) {
my $exception = $_;
my $found_transfer = $_->transfer;
@ -477,8 +477,7 @@ sub TransferCollection {
item => $item_object,
found_transfer => $found_transfer
};
}
else {
} else {
my $transfer = $item_object->request_transfer(
{
to => $to_library,
@ -493,16 +492,14 @@ sub TransferCollection {
# we were at the first stage.. then there won't be a datearrived
# to calculate against. See bug 35100
}
}
elsif ( $_->isa('Koha::Exceptions::Item::Transfer::Limit') ) {
} elsif ( $_->isa('Koha::Exceptions::Item::Transfer::Limit') ) {
push @{$messages},
{
type => 'error',
code => 'limits',
item => $item_object
};
}
else {
} else {
$_->rethrow();
}
};
@ -551,9 +548,8 @@ sub isItemInThisCollection {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare(
"SELECT COUNT(*) as inCollection FROM collections_tracking WHERE itemnumber = ? AND colId = ?"
);
my $sth =
$dbh->prepare("SELECT COUNT(*) as inCollection FROM collections_tracking WHERE itemnumber = ? AND colId = ?");
$sth->execute( $itemnumber, $colId ) or return (0);
my $row = $sth->fetchrow_hashref;
@ -581,8 +577,7 @@ sub isItemInAnyCollection {
$itemnumber = $row->{itemnumber};
if ($itemnumber) {
return 1;
}
else {
} else {
return 0;
}
}

93
C4/SIP/ILS.pm
View File

@ -84,13 +84,18 @@ sub supports {
sub check_inst_id {
my ( $self, $id, $whence ) = @_;
if ( $id ne $self->{institution}->{id} ) {
siplog("LOG_WARNING", "%s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
siplog(
"LOG_WARNING", "%s: received institution '%s', expected '%s'", $whence, $id,
$self->{institution}->{id}
);
# Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
}
}
sub to_bool {
my $bool = shift;
# If it's defined, and matches a true sort of string, or is
# a non-zero number, then it's true.
defined($bool) or return; # false
@ -103,16 +108,19 @@ sub checkout_ok {
return ( exists( $self->{institution}->{policy}->{checkout} )
&& to_bool( $self->{institution}->{policy}->{checkout} ) );
}
sub checkin_ok {
my $self = shift;
return ( exists( $self->{institution}->{policy}->{checkin} )
&& to_bool( $self->{institution}->{policy}->{checkin} ) );
}
sub status_update_ok {
my $self = shift;
return ( exists( $self->{institution}->{policy}->{status_update} )
&& to_bool( $self->{institution}->{policy}->{status_update} ) );
}
sub offline_ok {
my $self = shift;
return ( exists( $self->{institution}->{policy}->{offline} )
@ -135,6 +143,7 @@ sub checkout {
@blocked_item_types = split /\|/, $account->{blocked_item_types};
}
$circ = C4::SIP::ILS::Transaction::Checkout->new();
# BEGIN TRANSACTION
$circ->patron( $patron = C4::SIP::ILS::Patron->new($patron_id) );
$circ->item( $item = C4::SIP::ILS::Item->new($item_id) );
@ -145,11 +154,10 @@ sub checkout {
if ( !$patron ) {
$circ->screen_msg("Invalid Patron");
}
elsif ( !$item ) {
} elsif ( !$item ) {
$circ->screen_msg("Invalid Item");
}
elsif ( $no_block_due_date ) {
} elsif ($no_block_due_date) {
# A no block due date means we need check this item out to the patron
# regardless if fines, restrictions or any other things that would
# typically prevent a patron from checking out.
@ -167,38 +175,35 @@ sub checkout {
"LOG_DEBUG", "ILS::Checkout: patron %s has checked out %s via a no block checkout",
$patron_id, join( ', ', map { $_->{barcode} } @{ $patron->{items} } )
);
}
elsif ( !$patron->charge_ok ) {
} elsif ( !$patron->charge_ok ) {
if ( $patron->debarred ) {
$circ->screen_msg("Patron debarred");
} elsif ( $patron->expired ) {
$circ->screen_msg("Patron expired on " . output_pref({ dt => dt_from_string( $patron->dateexpiry_iso, 'iso' ), dateonly => 1 }));
$circ->screen_msg( "Patron expired on "
. output_pref( { dt => dt_from_string( $patron->dateexpiry_iso, 'iso' ), dateonly => 1 } ) );
} elsif ( $patron->fine_blocked ) {
my $message = "Patron has fines";
if ( $account->{show_outstanding_amount} ) {
my $patron_account = Koha::Account->new( { patron_id => $patron->{borrowernumber} } );
my $balance = $patron_account->balance;
if ($balance) {
$message .= (" - You owe " . Koha::Number::Price->new( $balance )->format({ with_symbol => 1}) . ".");
$message .=
( " - You owe " . Koha::Number::Price->new($balance)->format( { with_symbol => 1 } ) . "." );
}
}
$circ->screen_msg($message);
} else {
$circ->screen_msg("Patron blocked");
}
}
elsif (
$item->{borrowernumber}
} elsif ( $item->{borrowernumber}
&& !C4::Context->preference('AllowItemsOnLoanCheckoutSIP')
&& !_ci_cardnumber_cmp( $item->{borrowernumber}, $patron->borrowernumber )
)
&& !_ci_cardnumber_cmp( $item->{borrowernumber}, $patron->borrowernumber ) )
{
$circ->screen_msg("Item checked out to another patron");
}
elsif (grep { $_ eq $item->{itemtype} } @blocked_item_types) {
} elsif ( grep { $_ eq $item->{itemtype} } @blocked_item_types ) {
$circ->screen_msg("Item type cannot be checked out at this checkout location");
}
else {
} else {
# No block checkouts were handled earlier so there is no need
# to bass the no block due date here.
$circ->do_checkout($account);
@ -218,8 +223,7 @@ sub checkout {
"LOG_DEBUG", "ILS::Checkout: patron %s has checked out %s",
$patron_id, join( ', ', map { $_->{barcode} } @{ $patron->{items} } )
);
}
else {
} else {
siplog( "LOG_ERR", "ILS::Checkout Issue failed" );
}
}
@ -231,6 +235,7 @@ sub checkout {
sub _ci_cardnumber_cmp {
my ( $s1, $s2 ) = @_;
# As the database is case insensitive we need to normalize two strings
# before comparing them
return ( uc($s1) eq uc($s2) );
@ -260,8 +265,7 @@ sub checkin {
my $data;
if ($item) {
$data = $circ->do_checkin( $current_loc, $return_date, $account );
}
else {
} else {
$circ->alert(1);
$circ->alert_type(99);
$circ->ok(0);
@ -319,7 +323,10 @@ sub checkin {
},
);
if ($charges) {
$message .= "You owe " . Koha::Number::Price->new( $charges->total_outstanding )->format({ with_symbol => 1}) . " for this item.";
$message .=
"You owe "
. Koha::Number::Price->new( $charges->total_outstanding )->format( { with_symbol => 1 } )
. " for this item.";
}
}
}
@ -327,6 +334,7 @@ sub checkin {
$circ->screen_msg($message);
}
} else {
# Checkin failed: Wrongbranch or withdrawn?
# Bug 10748 with pref BlockReturnOfLostItems adds another case to come
# here: returning a lost item when the pref is set.
@ -347,7 +355,10 @@ sub end_patron_session {
}
sub pay_fee {
my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type, $pay_type, $fee_id, $trans_id, $currency, $is_writeoff, $disallow_overpayment, $register_id) = @_;
my (
$self, $patron_id, $patron_pwd, $fee_amt, $fee_type, $pay_type, $fee_id, $trans_id, $currency, $is_writeoff,
$disallow_overpayment, $register_id
) = @_;
my $trans = C4::SIP::ILS::Transaction::FeePayment->new();
@ -356,11 +367,12 @@ sub pay_fee {
$trans->patron( $patron = C4::SIP::ILS::Patron->new($patron_id) );
if ( !$patron ) {
$trans->screen_msg('Invalid patron barcode.');
return {
status => $trans
};
return { status => $trans };
}
my $trans_result = $trans->pay( $patron->{borrowernumber}, $fee_amt, $pay_type, $fee_id, $is_writeoff, $disallow_overpayment, $register_id );
my $trans_result = $trans->pay(
$patron->{borrowernumber}, $fee_amt, $pay_type, $fee_id, $is_writeoff, $disallow_overpayment,
$register_id
);
my $ok = $trans_result->{ok};
$trans->ok($ok);
@ -372,8 +384,10 @@ sub pay_fee {
}
sub add_hold {
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
$expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
my (
$self, $patron_id, $patron_pwd, $item_id, $title_id,
$expiry_date, $pickup_location, $hold_type, $fee_ack
) = @_;
my ( $patron, $item );
my $trans = C4::SIP::ILS::Transaction::Hold->new();
@ -442,6 +456,7 @@ sub cancel_hold {
$trans->screen_msg( "Error with transaction drop_hold: " . $trans->screen_msg );
return $trans;
}
# Remove the hold from the patron's record first
$patron->drop_hold($item_id); # different than the transaction drop!
@ -450,6 +465,7 @@ sub cancel_hold {
foreach my $i ( 0 .. scalar @{ $item->hold_queue } ) {
$hold = $item->hold_queue->[$i];
if ( $item->barcode_is_borrowernumber( $patron->id, $hold->{borrowernumber} ) ) {
# found it: delete it.
splice @{ $item->hold_queue }, $i, 1;
last; # ?? should we keep going, in case there are multiples
@ -461,12 +477,13 @@ sub cancel_hold {
return $trans;
}
# The patron and item id's can't be altered, but the
# date, location, and type can.
sub alter_hold {
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
$expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
my (
$self, $patron_id, $patron_pwd, $item_id, $title_id,
$expiry_date, $pickup_location, $hold_type, $fee_ack
) = @_;
my ( $patron, $item );
my $hold;
my $trans;
@ -484,11 +501,13 @@ sub alter_hold {
$hold = $patron->{hold_items}[$i];
if ( $hold->{item_id} eq $item_id ) {
# Found it. So fix it.
$hold->{expiration_date} = $expiry_date if $expiry_date;
$hold->{pickup_location} = $pickup_location if $pickup_location;
$hold->{hold_type} = $hold_type if $hold_type;
$trans->change_hold();
# $trans->ok(1);
$trans->screen_msg("Hold updated.");
$trans->patron($patron);
@ -510,9 +529,11 @@ sub alter_hold {
}
sub renew {
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
my (
$self, $patron_id, $patron_pwd, $item_id, $title_id,
$no_block, $nb_due_date, $third_party,
$item_props, $fee_ack) = @_;
$item_props, $fee_ack
) = @_;
my ( $patron, $item );
my $trans;
@ -545,11 +566,13 @@ sub renew {
}
siplog( "LOG_DEBUG", "checking item %s of %s: $item_id vs. %s", ++$j, $count, $i->{barcode} );
if ( $i->{barcode} eq $item_id ) {
# We have it checked out
$item = C4::SIP::ILS::Item->new($item_id);
last;
}
}
# }
$trans->item($item);

43
C4/SIP/ILS/Item.pm
View File

@ -111,14 +111,26 @@ sub new {
my $biblio = Koha::Biblios->find( $self->{biblionumber} );
my $holds = $biblio->current_holds->unblessed;
$self->{hold_queue} = $holds;
$self->{hold_attached} = [( grep { defined $_->{found} and ( $_->{found} eq 'W' or $_->{found} eq 'P' or $_->{found} eq 'T' ) } @{$self->{hold_queue}} )];
$self->{pending_queue} = [( grep {(! defined $_->{found}) or ( $_->{found} ne 'W' and $_->{found} ne 'P' and $_->{found} ne 'T' ) } @{$self->{hold_queue}} )];
$self->{hold_attached} = [
(
grep { defined $_->{found} and ( $_->{found} eq 'W' or $_->{found} eq 'P' or $_->{found} eq 'T' ) }
@{ $self->{hold_queue} }
)
];
$self->{pending_queue} = [
(
grep { ( !defined $_->{found} ) or ( $_->{found} ne 'W' and $_->{found} ne 'P' and $_->{found} ne 'T' ) }
@{ $self->{hold_queue} }
)
];
$self->{title} = $biblio->title;
$self->{author} = $biblio->author;
bless $self, $type;
siplog( "LOG_DEBUG", "new ILS::Item('%s'): found with title '%s'",
$item_id, $self->{title} // '' );
siplog(
"LOG_DEBUG", "new ILS::Item('%s'): found with title '%s'",
$item_id, $self->{title} // ''
);
return $self;
}
@ -152,12 +164,15 @@ my %fields = (
sub next_hold {
my $self = shift;
# use Data::Dumper; warn "next_hold() hold_attached: " . Dumper($self->{hold_attached}); warn "next_hold() pending_queue: " . $self->{pending_queue};
foreach (@{$self->hold_attached}) { # If this item was taken from the hold shelf, then that reserve still governs
foreach ( @{ $self->hold_attached } )
{ # If this item was taken from the hold shelf, then that reserve still governs
next unless ( $_->{itemnumber} and $_->{itemnumber} == $self->{itemnumber} );
return $_;
}
if (scalar @{$self->{pending_queue}}) { # Otherwise, if there is at least one hold, the first (best priority) gets it
if ( scalar @{ $self->{pending_queue} } )
{ # Otherwise, if there is at least one hold, the first (best priority) gets it
return $self->{pending_queue}->[0];
}
return;
@ -178,6 +193,7 @@ sub hold_patron_id {
return;
}
sub hold_patron_name {
my ( $self, $template ) = @_;
my $borrowernumber = $self->hold_patron_id() or return q{};
@ -296,6 +312,7 @@ sub sip_security_marker {
my $self = shift;
return '02'; # FIXME? 00-other; 01-None; 02-Tattle-Tape Security Strip (3M); 03-Whisper Tape (3M)
}
sub sip_fee_type {
my $self = shift;
return '01'; # FIXME? 01-09 enumerated in spec. We just use O1-other/unknown.
@ -305,24 +322,29 @@ sub fee {
my $self = shift;
return $self->{fee} || 0;
}
sub fee_currency {
my $self = shift;
return $self->{currency} || 'USD';
}
sub owner {
my $self = shift;
return $self->{homebranch};
}
sub hold_queue {
my $self = shift;
( defined $self->{hold_queue} ) or return [];
return $self->{hold_queue};
}
sub pending_queue {
my $self = shift;
( defined $self->{pending_queue} ) or return [];
return $self->{pending_queue};
}
sub hold_attached {
my $self = shift;
( defined $self->{hold_attached} ) or return [];
@ -347,10 +369,12 @@ sub due_date {
my $self = shift;
return $self->{due_date} || 0;
}
sub recall_date {
my $self = shift;
return $self->{recall_date} || 0;
}
sub hold_pickup_date {
my $self = shift;
@ -385,7 +409,8 @@ sub available {
( $self->{borrowernumber} eq $for_patron ) or return 0;
return ( $count ? 0 : 1 );
} else { # not checked out
($count2) and return $self->barcode_is_borrowernumber($for_patron, $self->{hold_attached}[0]->{borrowernumber});
($count2)
and return $self->barcode_is_borrowernumber( $for_patron, $self->{hold_attached}[0]->{borrowernumber} );
}
return 0;
}
@ -394,8 +419,9 @@ sub _barcode_to_borrowernumber {
my $known = shift;
return unless defined $known;
my $patron = Koha::Patrons->find( { cardnumber => $known } ) or return;
return $patron->borrowernumber
return $patron->borrowernumber;
}
sub barcode_is_borrowernumber { # because hold_queue only has borrowernumber...
my $self = shift;
my $barcode = shift;
@ -461,7 +487,6 @@ sub build_custom_field_string {
my $string = q{};
return $string;
}

58
C4/SIP/ILS/Patron.pm
View File

@ -127,7 +127,8 @@ sub new {
# Get currency 3 chars max
my $currency = substr Koha::Acquisition::Currencies->get_active->currency, 0, 3;
my $circ_blocked =( C4::Context->preference('OverduesBlockCirc') ne "noblock" && defined $flags->{ODUES}->{itemlist} ) ? 1 : 0;
my $circ_blocked =
( C4::Context->preference('OverduesBlockCirc') ne "noblock" && defined $flags->{ODUES}->{itemlist} ) ? 1 : 0;
{
no warnings; # any of these $kp->{fields} being concat'd could be undef
%ilspatron = (
@ -228,7 +229,6 @@ sub new {
return $self;
}
# 0 means read-only
# 1 means read/write
@ -260,6 +260,7 @@ my %fields = (
too_many_overdue => 0, # for patron_status[6]
too_many_renewal => 0, # for patron_status[7]
too_many_claim_return => 0, # for patron_status[8]
# excessive_fines => 0, # for patron_status[10]
# excessive_fees => 0, # for patron_status[11]
recall_overdue => 0, # for patron_status[12]
@ -270,6 +271,7 @@ my %fields = (
our $AUTOLOAD;
sub DESTROY {
# be cool. needed for AUTOLOAD(?)
}
@ -337,7 +339,10 @@ sub too_many_lost {
my $too_many_lost = 0;
if ( $server && $server->{account} && ( my $lost_block_checkout = $server->{account}->{lost_block_checkout} ) ) {
my $lost_block_checkout_value = $server->{account}->{lost_block_checkout_value} // 1;
my $lost_checkouts = Koha::Checkouts->search({ borrowernumber => $self->borrowernumber, 'itemlost' => { '>=', $lost_block_checkout_value } }, { join => 'item'} )->count;
my $lost_checkouts = Koha::Checkouts->search(
{ borrowernumber => $self->borrowernumber, 'itemlost' => { '>=', $lost_block_checkout_value } },
{ join => 'item' }
)->count;
$too_many_lost = $lost_checkouts >= $lost_block_checkout;
}
return $too_many_lost;
@ -400,14 +405,12 @@ sub x_items {
if ( $start && $start > 1 ) {
--$start;
}
else {
} else {
$start = 0;
}
if ( $end && $end < @{ $self->{$array_var} } ) {
--$end;
}
else {
} else {
$end = @{ $self->{$array_var} };
--$end;
}
@ -434,10 +437,12 @@ sub overdue_items {
my $self = shift;
return $self->x_items( 'overdue_items', @_ );
}
sub charged_items {
my $self = shift;
return $self->x_items( 'items', @_ );
}
sub fine_items {
require Koha::Database;
@ -448,8 +453,7 @@ sub fine_items {
my $end = shift;
my $server = shift;
my @fees =
Koha::Database->new()->schema()->resultset('Accountline')->search(
my @fees = Koha::Database->new()->schema()->resultset('Accountline')->search(
{
borrowernumber => $self->{borrowernumber},
amountoutstanding => { '>' => '0' },
@ -459,10 +463,8 @@ sub fine_items {
$start = $start ? $start - 1 : 0;
$end = $end ? $end - 1 : scalar @fees - 1;
my $av_field_template =
$server ? $server->{account}->{av_field_template} : undef;
$av_field_template ||=
"[% accountline.description %] [% accountline.amountoutstanding | format('%.2f') %]";
my $av_field_template = $server ? $server->{account}->{av_field_template} : undef;
$av_field_template ||= "[% accountline.description %] [% accountline.amountoutstanding | format('%.2f') %]";
my @return_values;
for ( my $i = $start ; $i <= $end ; $i++ ) {
@ -482,6 +484,7 @@ sub recall_items {
my $self = shift;
return $self->x_items( 'recall_items', @_ );
}
sub unavail_holds {
my $self = shift;
return $self->x_items( 'unavail_holds', @_ );
@ -492,7 +495,8 @@ sub block {
foreach my $field ( 'charge_ok', 'renew_ok', 'recall_ok', 'hold_ok', 'inet' ) {
$self->{$field} = 0;
}
$self->{screen_msg} = "Block feature not implemented"; # $blocked_card_msg || "Card Blocked. Please contact library staff";
$self->{screen_msg} =
"Block feature not implemented"; # $blocked_card_msg || "Card Blocked. Please contact library staff";
# TODO: not really affecting patron record
return $self;
}
@ -502,10 +506,13 @@ sub enable {
foreach my $field ( 'charge_ok', 'renew_ok', 'recall_ok', 'hold_ok', 'inet' ) {
$self->{$field} = 1;
}
siplog("LOG_DEBUG", "Patron(%s)->enable: charge: %s, renew:%s, recall:%s, hold:%s",
siplog(
"LOG_DEBUG", "Patron(%s)->enable: charge: %s, renew:%s, recall:%s, hold:%s",
$self->{id}, $self->{charge_ok}, $self->{renew_ok},
$self->{recall_ok}, $self->{hold_ok});
$self->{screen_msg} = "Enable feature not implemented."; # "All privileges restored."; # TODO: not really affecting patron record
$self->{recall_ok}, $self->{hold_ok}
);
$self->{screen_msg} =
"Enable feature not implemented."; # "All privileges restored."; # TODO: not really affecting patron record
return $self;
}
@ -526,8 +533,7 @@ sub excessive_fines {
sub holds_blocked_by_excessive_fees {
my $self = shift;
return ( $self->fee_amount
&& $self->fee_amount > C4::Context->preference("maxoutstanding") );
return ( $self->fee_amount && $self->fee_amount > C4::Context->preference("maxoutstanding") );
}
sub library_name {
@ -556,14 +562,12 @@ sub _get_address {
my $patron = shift;
my $address = $patron->{streetnumber} || q{};
for my $field (qw( roaddetails address address2 city state zipcode country))
{
for my $field (qw( roaddetails address address2 city state zipcode country)) {
next unless $patron->{$field};
if ($address) {
$address .= q{ };
$address .= $patron->{$field};
}
else {
} else {
$address .= $patron->{$field};
}
}
@ -580,8 +584,8 @@ sub _get_outstanding_holds {
my $item;
if ( $hold->itemnumber ) {
$item = $hold->item;
}
else {
} else {
# We need to return a barcode for the biblio so the client
# can request the biblio info
my $items = $hold->biblio->items;
@ -631,7 +635,6 @@ sub build_patron_attributes_string {
return $string;
}
=head2 build_custom_field_string
This method builds the part of the sip message for custom patron fields as defined in the sip config
@ -649,7 +652,8 @@ sub build_custom_field_string {
? @{ $server->{account}->{custom_patron_field} }
: $server->{account}->{custom_patron_field};
foreach my $custom_field (@custom_fields) {
$string .= maybe_add( $custom_field->{field}, $self->format( $custom_field->{template} ) ) if defined $custom_field->{field};
$string .= maybe_add( $custom_field->{field}, $self->format( $custom_field->{template} ) )
if defined $custom_field->{field};
}
}
return $string;

3
C4/SIP/ILS/Transaction.pm
View File

@ -53,9 +53,8 @@ sub duedatefromissue {
return $due_dt;
}
sub DESTROY {
# be cool
}

39
C4/SIP/ILS/Transaction/Checkin.pm
View File

@ -23,6 +23,7 @@ my %fields = (
magnetic => 0,
sort_bin => undef,
collection_code => undef,
# 3M extensions:
call_number => undef,
destination_loc => undef,
@ -61,16 +62,12 @@ sub do_checkin {
my $barcode = $self->{item}->id;
if ($return_date) {
$return_date = substr( $return_date, 0, 4 )
. '-'
. substr( $return_date, 4, 2 )
. '-'
. substr( $return_date, 6, 2 )
. q{ }
. substr( $return_date, 12, 2 )
. ':'
. substr( $return_date, 14, 2 )
. ':'
$return_date =
substr( $return_date, 0, 4 ) . '-'
. substr( $return_date, 4, 2 ) . '-'
. substr( $return_date, 6, 2 ) . q{ }
. substr( $return_date, 12, 2 ) . ':'
. substr( $return_date, 14, 2 ) . ':'
. substr( $return_date, 16, 2 );
$return_date = dt_from_string($return_date);
}
@ -97,8 +94,7 @@ sub do_checkin {
my $checkin_blocked_by_holds = $holds_block_checkin && $reserved;
( $return, $messages, $issue, $borrower ) =
AddReturn( $barcode, $branch, undef, $return_date )
( $return, $messages, $issue, $borrower ) = AddReturn( $barcode, $branch, undef, $return_date )
unless $human_required || $checkin_blocked_by_holds;
if ($checked_in_ok) {
@ -159,22 +155,27 @@ sub do_checkin {
$self->hold( $messages->{ResFound} );
$self->alert_type('02');
if ($holds_get_captured) {
ModReserveAffect( $item->itemnumber,
ModReserveAffect(
$item->itemnumber,
$messages->{ResFound}->{borrowernumber},
1, $messages->{ResFound}->{reserve_id} );
ModItemTransfer( $item->itemnumber, $branch,
$messages->{ResFound}->{branchcode}, 'Reserve', );
1, $messages->{ResFound}->{reserve_id}
);
ModItemTransfer(
$item->itemnumber, $branch,
$messages->{ResFound}->{branchcode}, 'Reserve',
);
}
}
$self->{item}->hold_patron_id( $messages->{ResFound}->{borrowernumber} );
$self->{item}->destination_loc( $messages->{ResFound}->{branchcode} );
}
# ignoring messages: NotIssued, WasTransfered
if ($cv_triggers_alert) {
$self->alert( defined $self->alert_type ); # Overwrites existing alert value, should set to 0 if there is no alert type
}
else {
$self->alert( defined $self->alert_type )
; # Overwrites existing alert value, should set to 0 if there is no alert type
} else {
$self->alert( !$return || defined $self->alert_type );
}

9
C4/SIP/ILS/Transaction/Checkout.pm
View File

@ -30,7 +30,7 @@ my %fields = (
);
sub new {
my $class = shift;;
my $class = shift;
my $self = $class->SUPER::new();
foreach my $element ( keys %fields ) {
$self->{_permitted}->{$element} = $fields{$element};
@ -152,12 +152,15 @@ sub do_checkout {
if ($no_block_due_date) {
$overridden_duedate = $no_block_due_date;
ProcessOfflineIssue({
ProcessOfflineIssue(
{
cardnumber => $patron->cardnumber,
barcode => $barcode,
timestamp => $no_block_due_date,
});
}
);
} else {
# can issue
my $recall_id;
foreach ( keys %{$messages} ) {

13
C4/SIP/ILS/Transaction/FeePayment.pm
View File

@ -72,11 +72,8 @@ sub pay {
my $fee = Koha::Account::Lines->find($fee_id);
if ($fee) {
$pay_options->{lines} = [$fee];
}
else {
return {
ok => 0
};
} else {
return { ok => 0 };
}
}
@ -85,14 +82,12 @@ sub pay {
my $error;
try {
$pay_response = $account->pay($pay_options);
}
catch {
} catch {
$ok = 0;
if ( ref($_) =~ /^Koha::Exceptions/ ) {
$error = $_->description;
}
else {
} else {
$_->rethrow;
}
};

3
C4/SIP/ILS/Transaction/Hold.pm
View File

@ -121,7 +121,8 @@ sub change_hold {
$self->ok(0);
return $self;
}
ModReserve({ biblionumber => $item->biblionumber, borrowernumber => $patron->borrowernumber, branchcode => $branch });
ModReserve(
{ biblionumber => $item->biblionumber, borrowernumber => $patron->borrowernumber, branchcode => $branch } );
$self->ok(1);
return $self;

3
C4/SIP/ILS/Transaction/RenewAll.pm
View File

@ -58,8 +58,7 @@ sub do_renew_all {
if ( $self->renewal_ok ) {
$item->{due_date} = $self->{due};
push @{ $self->{renewed} }, $item_id;
}
else {
} else {
push @{ $self->{unrenewed} }, $item_id;
}
$self->screen_msg(q{}); # clear indiv message

36
C4/SIP/SIPServer.pm
View File

@ -30,7 +30,6 @@ use base qw(Net::Server::PreFork);
use constant LOG_SIP => "local6"; # Local alias for the logging facility
set_logger( Koha::Logger->get( { interface => 'sip' } ) );
#
@ -70,7 +69,6 @@ foreach my $svc (keys %{$config->{listeners}}) {
#
# The IDENT is determined by config file 'server-params' arguments
#
# Server Management: set parameters for the Net::Server::PreFork
# module. The module silently ignores parameters that it doesn't
@ -82,6 +80,7 @@ if (defined($config->{'server-params'})) {
push @parms, $key . '=' . $val;
}
}
# Add user and group to prevent warn from Net::Server.
push @parms, 'user=' . $>;
push @parms, 'group=' . $>;
@ -250,7 +249,10 @@ sub process_request {
$self->{service} = $config->find_service( $sockaddr, $port, $proto );
if ( !defined( $self->{service} ) ) {
siplog("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
siplog(
"LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port,
$proto
);
die "process_request: Bad server connection";
}
@ -273,6 +275,7 @@ sub raw_transport {
my $self = shift;
my $input;
my $service = $self->{service};
# If using Net::Server::PreFork you may already have account set from a previous session
# Ensure you dont
if ( $self->{account} ) {
@ -288,14 +291,16 @@ sub raw_transport {
while ( !$self->{account} ) {
$input = read_request();
if ( !$input ) {
# EOF on the socket
siplog( "LOG_INFO", "raw_transport: shutting down: EOF during login" );
return;
}
$input =~ s/[\r\n]+$//sm; # Strip off trailing line terminator(s)
my $reg = qr/^${\(LOGIN)}/;
last if $input !~ $reg ||
C4::SIP::Sip::MsgType::handle($input, $self, LOGIN);
last
if $input !~ $reg
|| C4::SIP::Sip::MsgType::handle( $input, $self, LOGIN );
}
alarm 0;
@ -312,9 +317,11 @@ sub raw_transport {
Koha::Logger->put_mdc( "accountid", $self->{account}->{id} );
Koha::Logger->put_mdc( "peeraddr", $self->{server}->{peeraddr} );
siplog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
siplog(
"LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
$self->{account}->{id},
$self->{account}->{institution});
$self->{account}->{institution}
);
if ( !$self->{account}->{id} ) {
siplog( "LOG_ERR", "Login failed shutting down" );
return;
@ -369,9 +376,11 @@ sub telnet_transport {
while ( $strikes-- ) {
print "login: ";
alarm $timeout;
# $uid = &get_clean_input;
$uid = <STDIN>;
print "password: ";
# $pwd = &get_clean_input || '';
$pwd = <STDIN>;
alarm 0;
@ -382,7 +391,8 @@ sub telnet_transport {
siplog( "LOG_DEBUG", "telnet_transport 2: uid length %s, pwd length %s", length($uid), length($pwd) );
if ( exists( $config->{accounts}->{$uid} )
&& ($pwd eq $config->{accounts}->{$uid}->{password})) {
&& ( $pwd eq $config->{accounts}->{$uid}->{password} ) )
{
$account = $config->{accounts}->{$uid};
if ( C4::SIP::Sip::MsgType::login_core( $self, $uid, $pwd ) ) {
last;
@ -486,6 +496,7 @@ sub read_request {
chomp $buffer;
$raw_length = length $buffer;
$buffer =~ s/^\s*[^A-z0-9]+//s;
# Every line must start with a "real" character. Not whitespace, control chars, etc.
$buffer =~ s/[^A-z0-9]+$//s;
@ -495,8 +506,7 @@ sub read_request {
$buffer =~ s/\015*\012*$//s;
# treat as one line to include the extra linebreaks we are trying to remove!
}
else {
} else {
siplog( 'LOG_DEBUG', 'EOF returned on read' );
return;
}
@ -526,13 +536,15 @@ sub get_timeout {
my $service = $server->{service} // {};
my $config = $server->{config} // {};
if( $params->{transport} ||
( $params->{client} && !exists $service->{client_timeout} )) {
if ( $params->{transport}
|| ( $params->{client} && !exists $service->{client_timeout} ) )
{
# We do not allow zero values here.
# Note: config/timeout seems to be deprecated.
return $service->{timeout} || $config->{timeout} || $fallback;
} elsif ( $params->{client} ) {
# We know that client_timeout exists now.
# We do allow zero values here to indicate no timeout.
return 0 if $service->{client_timeout} =~ /^0+$|\D/;

23
C4/SIP/Sip.pm
View File

@ -25,10 +25,13 @@ our @EXPORT_OK = qw(y_or_n timestamp add_field maybe_add add_count
$last_response siplog);
our %EXPORT_TAGS = (
all => [qw(y_or_n timestamp add_field maybe_add
all => [
qw(y_or_n timestamp add_field maybe_add
add_count denied sipbool boolspace write_msg
$error_detection $protocol_version
$field_delimiter $last_response siplog)]);
$field_delimiter $last_response siplog)
]
);
our $error_detection = 0;
our $protocol_version = 1;
@ -47,6 +50,7 @@ sub timestamp {
if ( ref $time eq 'DateTime' ) {
return $time->strftime(SIP_DATETIME);
} elsif ( $time =~ m/^(\d{4})\-(\d{2})\-(\d{2})/ ) {
# passing a db returned date as is + bogus time
return sprintf( '%04d%02d%02d 235900', $1, $2, $3 );
}
@ -65,8 +69,10 @@ sub add_field {
my ( $i, $ent );
if ( !defined($value) ) {
siplog("LOG_DEBUG", "add_field: Undefined value being added to '%s'",
$field_id);
siplog(
"LOG_DEBUG", "add_field: Undefined value being added to '%s'",
$field_id
);
$value = '';
}
$value =~ s/\r/ /g; # CR terminates a sip message
@ -97,7 +103,8 @@ sub maybe_add {
foreach my $regex (
ref $server->{account}->{screen_msg_regex} eq "ARRAY"
? @{ $server->{account}->{screen_msg_regex} }
: $server->{account}->{screen_msg_regex} )
: $server->{account}->{screen_msg_regex}
)
{
$value =~ s/$regex->{find}/$regex->{replace}/g;
}
@ -142,8 +149,10 @@ sub add_count {
$count = sprintf( "%04d", $count );
if ( length($count) != 4 ) {
siplog("LOG_WARNING", "handle_patron_info: %s wrong size: '%s'",
$label, $count);
siplog(
"LOG_WARNING", "handle_patron_info: %s wrong size: '%s'",
$label, $count
);
$count = ' ' x 4;
}
return $count;

1
C4/SIP/Sip/Checksum.pm
View File

@ -21,6 +21,7 @@ sub verify_cksum {
warn "verify_cksum: no sum detected";
return 0; # No checksum at end
}
# return 0 if (substr($pkt, -6, 2) ne "AZ");
# Convert the checksum back to hex and calculate the sum of the

11
C4/SIP/Sip/Configuration.pm
View File

@ -52,7 +52,10 @@ sub new {
my @branchcodes = Koha::Libraries->search()->get_column('branchcode');
my @institutions = uniq( keys %{ $cfg->{institutions} } );
foreach my $i (@institutions) {
siplog("LOG_ERR", "ERROR: Institution $i does does not match a branchcode. This can cause unexpected behavior.") unless grep( /^$i$/, @branchcodes );
siplog(
"LOG_ERR",
"ERROR: Institution $i does does not match a branchcode. This can cause unexpected behavior."
) unless grep( /^$i$/, @branchcodes );
}
return bless $cfg, $class;
@ -73,8 +76,10 @@ sub find_service {
my $portstr;
foreach my $addr ( '', '*:', "$sockaddr:", "[$sockaddr]:" ) {
$portstr = sprintf( "%s%s/%s", $addr, $port, lc $proto );
siplog( "LOG_DEBUG",
"Configuration::find_service: Trying $portstr" );
siplog(
"LOG_DEBUG",
"Configuration::find_service: Trying $portstr"
);
last if ( exists( ( $self->{listeners} )->{$portstr} ) );
$portstr .= '/ipv4'; # lc, see ->new
last if ( exists( ( $self->{listeners} )->{$portstr} ) );

23
C4/SIP/Sip/Constants.pm
View File

@ -17,7 +17,8 @@ BEGIN {
@ISA = qw(Exporter);
%EXPORT_TAGS = (
SC_msgs => [qw(
SC_msgs => [
qw(
PATRON_STATUS_REQ
CHECKOUT CHECKIN
SC_STATUS REQUEST_ACS_RESEND
@ -26,9 +27,11 @@ BEGIN {
HOLD RENEW RENEW_ALL
PATRON_ENABLE
BLOCK_PATRON
)],
)
],
ACS_msgs => [qw(
ACS_msgs => [
qw(
PATRON_STATUS_RESP
CHECKOUT_RESP CHECKIN_RESP
ACS_STATUS REQUEST_SC_RESEND
@ -36,13 +39,15 @@ BEGIN {
FEE_PAID_RESP ITEM_INFO_RESP ITEM_STATUS_UPDATE_RESP
HOLD_RESP RENEW_RESP RENEW_ALL_RESP
PATRON_ENABLE_RESP
)],
)
],
SC_status => [qw(SC_STATUS_OK SC_STATUS_PAPER SC_STATUS_SHUTDOWN)],
formats => [qw(SIP_DATETIME)],
constant_msgs => [qw(REQUEST_ACS_RESEND_CKSUM REQUEST_SC_RESEND_CKSUM)],
field_ids => [qw(
field_ids => [
qw(
FID_PATRON_ID FID_ITEM_ID
FID_TERMINAL_PWD FID_PATRON_PWD
FID_PERSONAL_NAME FID_DUE_DATE
@ -89,7 +94,8 @@ BEGIN {
FID_ALERT_TYPE
FID_HOLD_PATRON_ID
FID_HOLD_PATRON_NAME
)],
)
],
);
# Add the contents of the other ":class" tags to make an ":all" class (deleting duplicates)
@ -162,8 +168,10 @@ use constant {
FID_SCREEN_MSG => 'AF',
FID_PRINT_LINE => 'AG',
FID_DUE_DATE => 'AH',
# UNUSED AI
FID_TITLE_ID => 'AJ',
# UNUSED AK
FID_BLOCKED_CARD_MSG => 'AL',
FID_LIBRARY_NAME => 'AM',
@ -171,6 +179,7 @@ use constant {
FID_INST_ID => 'AO',
FID_CURRENT_LOCN => 'AP',
FID_PERM_LOCN => 'AQ',
# UNUSED AR
FID_HOLD_ITEMS => 'AS', # SIP 2.0
FID_OVERDUE_ITEMS => 'AT', # SIP 2.0
@ -191,6 +200,7 @@ use constant {
FID_OWNER => 'BG',
FID_CURRENCY => 'BH',
FID_CANCEL => 'BI',
# UNUSED BJ
FID_TRANSACTION_ID => 'BK',
FID_VALID_PATRON => 'BL',
@ -212,6 +222,7 @@ use constant {
FID_CHARGED_ITEMS_LMT => 'CB',
FID_FEE_LMT => 'CC',
FID_UNAVAILABLE_HOLD_ITEMS => 'CD',
# UNUSED CE
FID_HOLD_QUEUE_LEN => 'CF',
FID_FEE_ID => 'CG',

159
C4/SIP/Sip/MsgType.pm
View File

@ -81,7 +81,10 @@ my %handlers = (
2 => {
template => "A1A1A18A18",
template_len => 38,
fields => [ (FID_INST_ID), (FID_PATRON_ID), (FID_ITEM_ID), (FID_TERMINAL_PWD), (FID_ITEM_PROPS), (FID_PATRON_PWD), (FID_FEE_ACK), (FID_CANCEL) ],
fields => [
(FID_INST_ID), (FID_PATRON_ID), (FID_ITEM_ID), (FID_TERMINAL_PWD), (FID_ITEM_PROPS),
(FID_PATRON_PWD), (FID_FEE_ACK), (FID_CANCEL)
],
},
}
},
@ -97,7 +100,9 @@ my %handlers = (
2 => {
template => "A1A18A18",
template_len => 37,
fields => [ (FID_CURRENT_LOCN), (FID_INST_ID), (FID_ITEM_ID), (FID_TERMINAL_PWD), (FID_ITEM_PROPS), (FID_CANCEL) ],
fields => [
(FID_CURRENT_LOCN), (FID_INST_ID), (FID_ITEM_ID), (FID_TERMINAL_PWD), (FID_ITEM_PROPS), (FID_CANCEL)
],
}
}
},
@ -152,7 +157,10 @@ my %handlers = (
2 => {
template => "A3A18A10",
template_len => 31,
fields => [ (FID_INST_ID), (FID_PATRON_ID), (FID_TERMINAL_PWD), (FID_PATRON_PWD), (FID_START_ITEM), (FID_END_ITEM) ],
fields => [
(FID_INST_ID), (FID_PATRON_ID), (FID_TERMINAL_PWD), (FID_PATRON_PWD), (FID_START_ITEM),
(FID_END_ITEM)
],
}
}
},
@ -174,7 +182,10 @@ my %handlers = (
2 => {
template => "A18A2A2A3",
template_len => 25,
fields => [ (FID_FEE_AMT), (FID_INST_ID), (FID_PATRON_ID), (FID_TERMINAL_PWD), (FID_PATRON_PWD), (FID_FEE_ID), (FID_TRANSACTION_ID) ],
fields => [
(FID_FEE_AMT), (FID_INST_ID), (FID_PATRON_ID), (FID_TERMINAL_PWD), (FID_PATRON_PWD), (FID_FEE_ID),
(FID_TRANSACTION_ID)
],
}
}
},
@ -219,7 +230,8 @@ my %handlers = (
template => "AA18",
template_len => 19,
fields => [
(FID_EXPIRATION), (FID_PICKUP_LOCN), (FID_HOLD_TYPE), (FID_INST_ID), (FID_PATRON_ID), (FID_PATRON_PWD),
(FID_EXPIRATION), (FID_PICKUP_LOCN), (FID_HOLD_TYPE), (FID_INST_ID), (FID_PATRON_ID),
(FID_PATRON_PWD),
(FID_ITEM_ID), (FID_TITLE_ID), (FID_TERMINAL_PWD), (FID_FEE_ACK)
],
}
@ -232,7 +244,10 @@ my %handlers = (
2 => {
template => "A1A1A18A18",
template_len => 38,
fields => [ (FID_INST_ID), (FID_PATRON_ID), (FID_PATRON_PWD), (FID_ITEM_ID), (FID_TITLE_ID), (FID_TERMINAL_PWD), (FID_ITEM_PROPS), (FID_FEE_ACK) ],
fields => [
(FID_INST_ID), (FID_PATRON_ID), (FID_PATRON_PWD), (FID_ITEM_ID), (FID_TITLE_ID),
(FID_TERMINAL_PWD), (FID_ITEM_PROPS), (FID_FEE_ACK)
],
}
}
},
@ -271,14 +286,20 @@ sub new {
# it's using the 2.00 login process, so it must support 2.00.
$protocol_version = 2;
}
siplog( "LOG_DEBUG", "Sip::MsgType::new('%s', '%s...', '%s'): seq.no '%s', protocol %s", $class, substr( $msg, 0, 10 ), $msgtag, $seqno, $protocol_version );
siplog(
"LOG_DEBUG", "Sip::MsgType::new('%s', '%s...', '%s'): seq.no '%s', protocol %s", $class,
substr( $msg, 0, 10 ), $msgtag, $seqno, $protocol_version
);
# warn "SIP PROTOCOL: $protocol_version";
if ( !exists( $handlers{$msgtag} ) ) {
siplog( "LOG_WARNING", "new Sip::MsgType: Skipping message of unknown type '%s' in '%s'", $msgtag, $msg );
return;
} elsif ( !exists( $handlers{$msgtag}->{protocol}->{$protocol_version} ) ) {
siplog( "LOG_WARNING", "new Sip::MsgType: Skipping message '%s' unsupported by protocol rev. '%d'", $msgtag, $protocol_version );
siplog(
"LOG_WARNING", "new Sip::MsgType: Skipping message '%s' unsupported by protocol rev. '%d'", $msgtag,
$protocol_version
);
return;
}
@ -310,9 +331,13 @@ sub _initialize {
$self->{fields}->{$field} = undef;
}
siplog( "LOG_DEBUG", "Sip::MsgType::_initialize('%s', '%s', '%s', '%s', ...)", $self->{name}, $msg, $proto->{template}, $proto->{template_len} );
siplog(
"LOG_DEBUG", "Sip::MsgType::_initialize('%s', '%s', '%s', '%s', ...)", $self->{name}, $msg,
$proto->{template}, $proto->{template_len}
);
$self->{fixed_fields} = [ unpack( $proto->{template}, $msg ) ]; # see http://perldoc.perl.org/5.8.8/functions/unpack.html
$self->{fixed_fields} =
[ unpack( $proto->{template}, $msg ) ]; # see http://perldoc.perl.org/5.8.8/functions/unpack.html
# Skip over the fixed fields and the split the rest of
# the message into fields based on the delimiter and parse them
@ -322,7 +347,10 @@ sub _initialize {
if ( !exists( $self->{fields}->{$fn} ) ) {
siplog( "LOG_WARNING", "Unsupported field '%s' in %s message '%s'", $fn, $self->{name}, $msg );
} elsif ( defined( $self->{fields}->{$fn} ) ) {
siplog( "LOG_WARNING", "Duplicate field '%s' (previous value '%s') in %s message '%s'", $fn, $self->{fields}->{$fn}, $self->{name}, $msg );
siplog(
"LOG_WARNING", "Duplicate field '%s' (previous value '%s') in %s message '%s'", $fn,
$self->{fields}->{$fn}, $self->{name}, $msg
);
} else {
$self->{fields}->{$fn} = substr( $field, 2 );
}
@ -396,7 +424,8 @@ sub handle {
if ( ( substr( $msg, 0, 2 ) ne REQUEST_ACS_RESEND )
&& $req
&& ( substr( $msg, 0, 2 ) ne $req ) ) {
&& ( substr( $msg, 0, 2 ) ne $req ) )
{
return substr( $msg, 0, 2 );
}
unless ( $self->{handler} ) {
@ -441,12 +470,12 @@ sub build_patron_status {
$resp .= patron_status_string( $patron, $server );
$resp .= $lang . timestamp();
if ( defined $server->{account}->{ae_field_template} ) {
$resp .= add_field( FID_PERSONAL_NAME, $patron->format( $server->{account}->{ae_field_template}, $server ) );
$resp .=
add_field( FID_PERSONAL_NAME, $patron->format( $server->{account}->{ae_field_template}, $server ) );
} else {
$resp .= add_field( FID_PERSONAL_NAME, $patron->name, $server );
}
# while the patron ID we got from the SC is valid, let's
# use the one returned from the ILS, just in case...
$resp .= add_field( FID_PATRON_ID, $patron->id, $server );
@ -472,6 +501,7 @@ sub build_patron_status {
$resp .= $patron->build_patron_attributes_string($server);
} else {
# Invalid patron (cardnumber)
# Report that the user has no privs.
@ -600,9 +630,8 @@ sub handle_checkout {
$resp .= maybe_add( FID_ITEM_PROPS, $item->sip_item_properties, $server );
}
}
else {
} else {
# Checkout failed
# Checkout Response: not ok, no renewal, don't know mag. media,
@ -631,7 +660,10 @@ sub handle_checkout {
if ( $patron && exists( $fields->{FID_PATRON_PWD} ) ) {
# Password provided, so we can tell if it was valid or not
$resp .= add_field( FID_VALID_PATRON_PWD, sipbool( $patron->check_password( $fields->{ (FID_PATRON_PWD) } ) ), $server );
$resp .= add_field(
FID_VALID_PATRON_PWD,
sipbool( $patron->check_password( $fields->{ (FID_PATRON_PWD) } ) ), $server
);
}
}
}
@ -678,7 +710,11 @@ sub handle_checkin {
if ( $no_block eq 'Y' ) {
# Off-line transactions, ick.
siplog( "LOG_WARNING", "received no-block checkin from terminal '%s' - no-block checkin not supported", $account->{id} );
siplog(
"LOG_WARNING", "received no-block checkin from terminal '%s' - no-block checkin not supported",
$account->{id}
);
#FIXME We need to write the routine called below
#$status = $ils->checkin_no_block( $item_id, $trans_date, $return_date, $item_props, $cancel );
#Until we do, lets just checkin the item
@ -723,8 +759,12 @@ sub handle_checkin {
$resp .= maybe_add( FID_ITEM_PROPS, $item->sip_item_properties, $server );
$resp .= maybe_add( FID_CALL_NUMBER, $item->call_number, $server );
$resp .= maybe_add( FID_HOLD_PATRON_ID, $item->hold_patron_bcode, $server );
$resp .= add_field( FID_DESTINATION_LOCATION, $item->destination_loc, $server ) if ( $item->destination_loc || $server->{account}->{ct_always_send} );
$resp .= maybe_add( FID_HOLD_PATRON_NAME, $item->hold_patron_name( $server->{account}->{da_field_template} ), $server );
$resp .= add_field( FID_DESTINATION_LOCATION, $item->destination_loc, $server )
if ( $item->destination_loc || $server->{account}->{ct_always_send} );
$resp .= maybe_add(
FID_HOLD_PATRON_NAME, $item->hold_patron_name( $server->{account}->{da_field_template} ),
$server
);
if ( my $CR = $server->{account}->{cr_item_field} ) {
$resp .= maybe_add( FID_COLLECTION_CODE, $item->{$CR}, $server );
@ -733,7 +773,10 @@ sub handle_checkin {
}
if ( $status->hold and $status->hold->{branchcode} ne $item->destination_loc ) {
warn 'SIP hold mismatch: $status->hold->{branchcode}=' . $status->hold->{branchcode} . '; $item->destination_loc=' . $item->destination_loc;
warn 'SIP hold mismatch: $status->hold->{branchcode}='
. $status->hold->{branchcode}
. '; $item->destination_loc='
. $item->destination_loc;
# just me being paranoid.
}
@ -820,9 +863,15 @@ sub handle_sc_status {
}
if ( $status == SC_STATUS_PAPER ) {
siplog( "LOG_WARNING", "Self-Check unit '%s@%s' out of paper", $self->{account}->{id}, $self->{account}->{institution} );
siplog(
"LOG_WARNING", "Self-Check unit '%s@%s' out of paper", $self->{account}->{id},
$self->{account}->{institution}
);
} elsif ( $status == SC_STATUS_SHUTDOWN ) {
siplog( "LOG_WARNING", "Self-Check unit '%s@%s' shutting down", $self->{account}->{id}, $self->{account}->{institution} );
siplog(
"LOG_WARNING", "Self-Check unit '%s@%s' shutting down", $self->{account}->{id},
$self->{account}->{institution}
);
}
$self->{account}->{print_width} = $print_width;
@ -838,7 +887,8 @@ sub handle_request_acs_resend {
# REQUEST_SC_RESEND msg (p. 16)
$self->write_msg( REQUEST_SC_RESEND, $server );
} elsif ( ( length($last_response) < 9 )
|| substr( $last_response, -9, 2 ) ne 'AY' ) {
|| substr( $last_response, -9, 2 ) ne 'AY' )
{
# When resending a message, we aren't supposed to include
# a sequence number, even if the original had one (p. 4).
@ -879,7 +929,10 @@ sub login_core {
my $auth_status = api_auth( $uid, $pwd, $inst );
if ( !$auth_status or $auth_status !~ /^ok$/i ) {
siplog( "LOG_WARNING", "api_auth failed for SIP terminal '%s' of '%s': %s", $uid, $inst, ( $auth_status || 'unknown' ) );
siplog(
"LOG_WARNING", "api_auth failed for SIP terminal '%s' of '%s': %s", $uid, $inst,
( $auth_status || 'unknown' )
);
$status = 0;
} else {
siplog( "LOG_INFO", "Successful login/auth for '%s' of '%s'", $server->{account}->{id}, $inst );
@ -896,7 +949,10 @@ sub login_core {
}
$module->use;
if ($@) {
siplog( "LOG_ERR", "%s: Loading ILS implementation '%s' for institution '%s' failed", $server->{service}, $module, $inst );
siplog(
"LOG_ERR", "%s: Loading ILS implementation '%s' for institution '%s' failed",
$server->{service}, $module, $inst
);
die("Failed to load ILS implementation '$module' for $inst");
}
@ -926,7 +982,10 @@ sub handle_login {
$pwd = $fields->{ (FID_LOGIN_PWD) }; # Terminal PWD, not patron PWD.
if ( $uid_algorithm || $pwd_algorithm ) {
siplog( "LOG_ERR", "LOGIN: Unsupported non-zero encryption method(s): uid = $uid_algorithm, pwd = $pwd_algorithm" );
siplog(
"LOG_ERR",
"LOGIN: Unsupported non-zero encryption method(s): uid = $uid_algorithm, pwd = $pwd_algorithm"
);
$status = 0;
} else {
$status = login_core( $server, $uid, $pwd );
@ -1021,7 +1080,8 @@ sub handle_patron_info {
# use the one returned from the ILS, just in case...
$resp .= add_field( FID_PATRON_ID, $patron->id, $server );
if ( defined $server->{account}->{ae_field_template} ) {
$resp .= add_field( FID_PERSONAL_NAME, $patron->format( $server->{account}->{ae_field_template} ), $server );
$resp .=
add_field( FID_PERSONAL_NAME, $patron->format( $server->{account}->{ae_field_template} ), $server );
} else {
$resp .= add_field( FID_PERSONAL_NAME, $patron->name, $server );
}
@ -1160,7 +1220,10 @@ sub handle_fee_paid {
$ils->check_inst_id( $inst_id, "handle_fee_paid" );
my $pay_result = $ils->pay_fee( $patron_id, $patron_pwd, $fee_amt, $fee_type, $pay_type, $fee_id, $trans_id, $currency, $is_writeoff, $disallow_overpayment, $register_id );
my $pay_result = $ils->pay_fee(
$patron_id, $patron_pwd, $fee_amt, $fee_type, $pay_type, $fee_id, $trans_id, $currency,
$is_writeoff, $disallow_overpayment, $register_id
);
$status = $pay_result->{status};
my $pay_response = $pay_result->{pay_response};
@ -1171,7 +1234,8 @@ sub handle_fee_paid {
"too_many" => "Renewed the maximum number of times",
"auto_too_soon" => "Scheduled for automatic renewal and cannot yet be renewed",
"auto_too_late" => "Scheduled for automatic renewal and cannot yet be any more",
"auto_account_expired" => "Scheduled for automatic renewal and cannot be renewed because the patron's account has expired",
"auto_account_expired" =>
"Scheduled for automatic renewal and cannot be renewed because the patron's account has expired",
"auto_renew" => "Scheduled for automatic renewal",
"auto_too_much_oweing" => "Scheduled for automatic renewal",
"on_reserve" => "On hold for another patron",
@ -1266,7 +1330,6 @@ sub handle_item_information {
$resp .= maybe_add( FID_CURRENT_LOCN, $item->current_location, $server );
$resp .= maybe_add( FID_ITEM_PROPS, $item->sip_item_properties, $server );
if ( my $CR = $server->{account}->{cr_item_field} ) {
$resp .= maybe_add( FID_COLLECTION_CODE, $item->{$CR}, $server );
} else {
@ -1438,13 +1501,22 @@ sub handle_hold {
Koha::Plugins->call( 'patron_barcode_transform', \$patron_id );
if ( $hold_mode eq '+' ) {
$status = $ils->add_hold( $patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type, $fee_ack );
$status = $ils->add_hold(
$patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type,
$fee_ack
);
} elsif ( $hold_mode eq '-' ) {
$status = $ils->cancel_hold( $patron_id, $patron_pwd, $item_id, $title_id );
} elsif ( $hold_mode eq '*' ) {
$status = $ils->alter_hold( $patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type, $fee_ack );
$status = $ils->alter_hold(
$patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type,
$fee_ack
);
} else {
siplog( "LOG_WARNING", "handle_hold: Unrecognized hold mode '%s' from terminal '%s'", $hold_mode, $server->{account}->{id} );
siplog(
"LOG_WARNING", "handle_hold: Unrecognized hold mode '%s' from terminal '%s'", $hold_mode,
$server->{account}->{id}
);
$status = $ils->Transaction::Hold; # new?
$status->screen_msg("System error. Please contact library staff.");
}
@ -1492,7 +1564,10 @@ sub handle_renew {
$ils->check_inst_id( $fields->{ (FID_INST_ID) }, "handle_renew" );
if ( $no_block eq 'Y' ) {
siplog( "LOG_WARNING", "handle_renew: received 'no block' renewal from terminal '%s'", $server->{account}->{id} );
siplog(
"LOG_WARNING", "handle_renew: received 'no block' renewal from terminal '%s'",
$server->{account}->{id}
);
}
$patron_id = $fields->{ (FID_PATRON_ID) };
@ -1504,7 +1579,10 @@ sub handle_renew {
Koha::Plugins->call( 'patron_barcode_transform', \$patron_id );
$status = $ils->renew( $patron_id, $patron_pwd, $item_id, $title_id, $no_block, $nb_due_date, $third_party, $item_props, $fee_ack );
$status = $ils->renew(
$patron_id, $patron_pwd, $item_id, $title_id, $no_block, $nb_due_date, $third_party, $item_props,
$fee_ack
);
$patron = $status->patron;
$item = $status->item;
@ -1648,10 +1726,12 @@ sub send_acs_status {
my $msg = ACS_STATUS;
($server) or die "send_acs_status error: no \$server argument received";
my $account = $server->{account} or die "send_acs_status error: no 'account' in \$server object:\n" . Dumper($server);
my $account = $server->{account}
or die "send_acs_status error: no 'account' in \$server object:\n" . Dumper($server);
my $policy = $server->{policy} or die "send_acs_status error: no 'policy' in \$server object:\n" . Dumper($server);
my $ils = $server->{ils} or die "send_acs_status error: no 'ils' in \$server object:\n" . Dumper($server);
my $sip_username = $server->{sip_username} or die "send_acs_status error: no 'sip_username' in \$server object:\n" . Dumper($server);
my $sip_username = $server->{sip_username}
or die "send_acs_status error: no 'sip_username' in \$server object:\n" . Dumper($server);
my ( $online_status, $checkin_ok, $checkout_ok, $ACS_renewal_policy );
my ( $status_update_ok, $offline_ok, $timeout, $retries );
my $sip_user = Koha::Patrons->find( { userid => $sip_username } );
@ -1709,7 +1789,8 @@ sub send_acs_status {
if ( defined( $account->{print_width} )
&& defined($print_line)
&& $account->{print_width} < length($print_line) ) {
&& $account->{print_width} < length($print_line) )
{
siplog( "LOG_WARNING", "send_acs_status: print line '%s' too long. Truncating", $print_line );
$print_line = substr( $print_line, 0, $account->{print_width} );
}

Some files were not shown because too many files have changed in this diff Show More