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 = {
},
},
],
}
};

18
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 {
@ -69,7 +67,7 @@ FIXME : if no replacement price, borrower just doesn't get charged?
sub chargelostitem {
my $dbh = C4::Context->dbh();
my ($borrowernumber, $itemnumber, $replacementprice, $description) = @_;
my ( $borrowernumber, $itemnumber, $replacementprice, $description ) = @_;
my $item = Koha::Items->find($itemnumber);
my $itype = $item->itemtype;
$replacementprice //= 0;
@ -77,17 +75,19 @@ sub chargelostitem {
my $processfee = $itype->processfee;
my $usedefaultreplacementcost = C4::Context->preference("useDefaultReplacementCost");
my $processingfeenote = C4::Context->preference("ProcessingFeeNote");
if ($usedefaultreplacementcost && $replacementprice == 0 && $defaultreplacecost){
if ( $usedefaultreplacementcost && $replacementprice == 0 && $defaultreplacecost ) {
$replacementprice = $defaultreplacecost;
}
my $checkout = Koha::Checkouts->find({ itemnumber => $itemnumber });
my $checkout = Koha::Checkouts->find( { itemnumber => $itemnumber } );
if ( !$checkout && $item->in_bundle ) {
my $host = $item->bundle_host;
$checkout = $host->checkout;
}
my $issue_id = $checkout ? $checkout->issue_id : undef;
my $account = Koha::Account->new({ patron_id => $borrowernumber });
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,8 +99,9 @@ sub chargelostitem {
# OK, they haven't
unless ($existing_charges) {
#add processing fee
if ($processfee && $processfee > 0){
if ( $processfee && $processfee > 0 ) {
my $accountline = $account->add_debit(
{
amount => $processfee,
@ -115,8 +116,9 @@ sub chargelostitem {
}
);
}
#add replace cost
if ($replacementprice > 0){
if ( $replacementprice > 0 ) {
my $accountline = $account->add_debit(
{
amount => $replacementprice,

682
C4/Acquisition.pm
View File

File diff suppressed because it is too large Load Diff

475
C4/Auth.pm
View File

File diff suppressed because it is too large Load Diff

55
C4/Auth_with_cas.pm
View File

@ -29,24 +29,25 @@ use URI::Escape;
use Koha::Logger;
our (@ISA, @EXPORT_OK);
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);
if ( multipleAuth() ) {
( $defaultcasserver, $casservers ) = YAML::XS::LoadFile($yamlauthfile);
$defaultcasserver = $defaultcasserver->{'default'};
} else {
# Else, we fall back to casServerUrl syspref
# Else, we fall back to casServerUrl syspref
$defaultcasserver = 'default';
$casservers = { 'default' => C4::Context->preference('casServerUrl') };
}
@ -57,7 +58,7 @@ if (multipleAuth()) {
# Is there a configuration file for multiple cas servers?
sub multipleAuth {
return (-e qq($yamlauthfile));
return ( -e qq($yamlauthfile) );
}
# Returns configured CAS servers' list if multiple authentication is enabled
@ -81,12 +82,11 @@ sub logout_cas {
print $query->redirect($logout_url);
}
# Login to CAS
sub login_cas {
my ($query, $type) = @_;
my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
print $query->redirect( $cas->login_url($uri));
my ( $query, $type ) = @_;
my ( $cas, $uri ) = _get_cas_and_service( $query, undef, $type );
print $query->redirect( $cas->login_url($uri) );
}
# Returns CAS login URL with callback to the requesting URL
@ -99,15 +99,15 @@ sub login_cas_url {
# Checks for password correctness
# In our case : is there a ticket, is it valid and does it match one of our users ?
sub checkpw_cas {
my ($ticket, $query, $type) = @_;
my ( $ticket, $query, $type ) = @_;
my $retnumber;
my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
my ( $cas, $uri ) = _get_cas_and_service( $query, undef, $type );
# If we got a ticket
if ($ticket) {
# We try to validate it
my $val = $cas->service_validate($uri, $ticket );
my $val = $cas->service_validate( $uri, $ticket );
# If it's valid
if ( $val->is_success() ) {
@ -133,9 +133,9 @@ sub checkpw_cas {
} else {
my $logger = Koha::Logger->get;
$logger->debug("Problem when validating ticket : $ticket");
$logger->debug("Authen::CAS::Client::Response::Error: " . $val->error()) if $val->is_error();
$logger->debug("Authen::CAS::Client::Response::Failure: " . $val->message()) if $val->is_failure();
$logger->debug(Data::Dumper::Dumper($@)) if $val->is_error() or $val->is_failure();
$logger->debug( "Authen::CAS::Client::Response::Error: " . $val->error() ) if $val->is_error();
$logger->debug( "Authen::CAS::Client::Response::Failure: " . $val->message() ) if $val->is_failure();
$logger->debug( Data::Dumper::Dumper($@) ) if $val->is_error() or $val->is_failure();
return 0;
}
}
@ -144,9 +144,9 @@ sub checkpw_cas {
# Proxy CAS auth
sub check_api_auth_cas {
my ($PT, $query, $type) = @_;
my ( $PT, $query, $type ) = @_;
my $retnumber;
my ( $cas, $uri ) = _get_cas_and_service($query, undef, $type);
my ( $cas, $uri ) = _get_cas_and_service( $query, undef, $type );
# If we have a Proxy Ticket
if ($PT) {
@ -193,7 +193,7 @@ sub _get_cas_and_service {
my $key = shift; # optional
my $type = shift;
my $uri = _url_with_get_params($query, $type);
my $uri = _url_with_get_params( $query, $type );
my $casparam = $defaultcasserver;
$casparam = $query->param('cas') if defined $query->param('cas');
@ -217,13 +217,14 @@ 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);
if ($uriPiece) {
$uri_params_part .= '&' if $uri_params_part;
$uri_params_part .= $param . '=';
$uri_params_part .= URI::Escape::uri_escape( $uriPiece );
$uri_params_part .= URI::Escape::uri_escape($uriPiece);
}
}
$uri_base_part .= '?' if $uri_params_part;
@ -238,14 +239,16 @@ sub _url_with_get_params {
=cut
sub logout_if_required {
my ( $query ) = @_;
my ($query) = @_;
# Check we havent been hit by a logout call
my $xml = $query->param('logoutRequest');
return 0 unless $xml;
my $dom = XML::LibXML->load_xml(string => $xml);
my $dom = XML::LibXML->load_xml( string => $xml );
my $ticket;
foreach my $node ($dom->findnodes('/samlp:LogoutRequest')){
foreach my $node ( $dom->findnodes('/samlp:LogoutRequest') ) {
# We got a cas single logout request from a cas server;
$ticket = $node->findvalue('./samlp:SessionIndex');
}
@ -254,7 +257,7 @@ sub logout_if_required {
# We've been called as part of the single logout destroy the session associated with the cas ticket
my $params = C4::Auth::_get_session_params();
my $success = CGI::Session->find( $params->{dsn}, sub {delete_cas_session(@_, $ticket)}, $params->{dsn_args} );
my $success = CGI::Session->find( $params->{dsn}, sub { delete_cas_session( @_, $ticket ) }, $params->{dsn_args} );
print $query->header;
exit;
@ -263,7 +266,7 @@ sub logout_if_required {
sub delete_cas_session {
my $session = shift;
my $ticket = shift;
if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
if ( $session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
$session->delete;
$session->flush;
}

187
C4/Auth_with_ldap.pm
View File

@ -29,7 +29,8 @@ use Koha::AuthUtils qw( hash_password );
use Net::LDAP;
use Net::LDAP::Filter;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -44,46 +45,52 @@ BEGIN {
# ~ and calls the memberadd if necessary
sub ldapserver_error {
return sprintf('No ldapserver "%s" defined in KOHA_CONF: ' . $ENV{KOHA_CONF}, shift);
return sprintf( 'No ldapserver "%s" defined in KOHA_CONF: ' . $ENV{KOHA_CONF}, shift );
}
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"');
}
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
$ldapname = $ldap->{user};
$ldappassword = $ldap->{pass};
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;
@mapkeys = grep { defined $mapping{$_}->{is} } @mapkeys;
#warn "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
my %categorycode_conversions;
my $default_categorycode;
if(defined $ldap->{categorycode_mapping}) {
if ( defined $ldap->{categorycode_mapping} ) {
$default_categorycode = $ldap->{categorycode_mapping}->{default};
foreach my $cat (@{$ldap->{categorycode_mapping}->{categorycode}}) {
$categorycode_conversions{$cat->{value}} = $cat->{content};
foreach my $cat ( @{ $ldap->{categorycode_mapping}->{categorycode} } ) {
$categorycode_conversions{ $cat->{value} } = $cat->{content};
}
}
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
update => defined($ldap->{update}) ? $ldap->{update} : 1, # update from LDAP to Koha database for existing user
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
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,27 +101,28 @@ sub search_method {
my $search = $db->search(
base => $base,
filter => $filter,
# attrs => ['*'],
);
die "LDAP search failed to return object : " . $search->error if $search->code;
my $count = $search->count;
if ($search->code > 0) {
warn sprintf("LDAP Auth rejected : %s gets %d hits\n", $filter->as_string, $count) . description($search);
if ( $search->code > 0 ) {
warn sprintf( "LDAP Auth rejected : %s gets %d hits\n", $filter->as_string, $count ) . description($search);
return 0;
}
if ($count == 0) {
warn sprintf("LDAP Auth rejected : search with filter '%s' returns no hit\n", $filter->as_string);
if ( $count == 0 ) {
warn sprintf( "LDAP Auth rejected : search with filter '%s' returns no hit\n", $filter->as_string );
return 0;
}
return $search;
}
sub checkpw_ldap {
my ($userid, $password) = @_;
my @hosts = split(',', $prefhost);
my $db = Net::LDAP->new(\@hosts);
unless ( $db ) {
my ( $userid, $password ) = @_;
my @hosts = split( ',', $prefhost );
my $db = Net::LDAP->new( \@hosts );
unless ($db) {
warn "LDAP connexion failed";
return 0;
}
@ -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
@ -173,17 +181,17 @@ sub checkpw_ldap {
$userldapentry = $search->shift_entry;
}
} else {
my $res = ($config{anonymous}) ? $db->bind : $db->bind($ldapname, password=>$ldappassword);
if ($res->code) { # connection refused
warn "LDAP bind failed as ldapuser " . ($ldapname || '[ANONYMOUS]') . ": " . description($res);
my $res = ( $config{anonymous} ) ? $db->bind : $db->bind( $ldapname, password => $ldappassword );
if ( $res->code ) { # connection refused
warn "LDAP bind failed as ldapuser " . ( $ldapname || '[ANONYMOUS]' ) . ": " . description($res);
return 0;
}
my $search = search_method($db, $userid) or return 0; # warnings are in the sub
my $search = search_method( $db, $userid ) or return 0; # warnings are in the sub
# Handle multiple branches. Same login exists several times in different branches.
my $bind_ok = 0;
while (my $entry = $search->shift_entry) {
my $user_ldap_bind_ret = $db->bind($entry->dn, password => $password);
unless ($user_ldap_bind_ret->code) {
while ( my $entry = $search->shift_entry ) {
my $user_ldap_bind_ret = $db->bind( $entry->dn, password => $password );
unless ( $user_ldap_bind_ret->code ) {
$userldapentry = $entry;
$bind_ok = 1;
last;
@ -195,19 +203,20 @@ sub checkpw_ldap {
return -1;
}
}
# To get here, LDAP has accepted our user's login attempt.
# But we still have work to do. See perldoc below for detailed breakdown.
my (%borrower);
my ($borrowernumber,$cardnumber,$local_userid,$savedpw) = exists_local($userid);
my ( $borrowernumber, $cardnumber, $local_userid, $savedpw ) = exists_local($userid);
my $patron;
if (( $borrowernumber and $config{update} ) or
(!$borrowernumber and $config{replicate}) ) {
%borrower = ldap_entry_2_hash($userldapentry,$cardnumber);
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";
}
@ -220,13 +229,10 @@ sub checkpw_ldap {
my $patron = Koha::Patrons->find($borrowernumber);
return ( 1, $cardnumber, $local_userid, $patron );
}
} elsif ($config{replicate}) { # A2, C2
} 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,19 +276,22 @@ 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);
my $attribute_types = Koha::Patron::Attribute::Types->search_with_library_limits( {}, {}, $library_id );
while ( my $attribute_type = $attribute_types->next ) {
my $code = $attribute_type->code;
unless (exists($borrower{$code}) && $borrower{$code} !~ m/^\s*$/ ) {
unless ( exists( $borrower{$code} ) && $borrower{$code} !~ m/^\s*$/ ) {
next;
}
$patron = Koha::Patrons->find($borrowernumber);
if ( $patron ) { # Should not be needed, but we are in C4::Auth LDAP...
if ($patron) { # Should not be needed, but we are in C4::Auth LDAP...
eval {
my $attribute = Koha::Patron::Attribute->new({code => $code, attribute => $borrower{$code}});
$patron->extended_attributes([$attribute->unblessed]);
my $attribute = Koha::Patron::Attribute->new( { code => $code, attribute => $borrower{$code} } );
$patron->extended_attributes( [ $attribute->unblessed ] );
};
if ($@) { # FIXME Test if Koha::Exceptions::Patron::Attribute::NonRepeatable
warn "ERROR_extended_unique_id_failed $code $borrower{$code}";
@ -290,7 +299,7 @@ sub checkpw_ldap {
}
}
}
return(1, $cardnumber, $userid, $patron);
return ( 1, $cardnumber, $userid, $patron );
}
# Pass LDAP entry object and local cardnumber (userid).
@ -307,40 +316,41 @@ 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->{$_}};
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
foreach my $key ( keys %mapping ) {
my $data = $memberhash{ lc( $mapping{$key}->{is} ) }; # Net::LDAP returns all names in lowercase
#warn "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
unless (defined $data) {
unless ( defined $data ) {
$data = $mapping{$key}->{content} || undef;
}
$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) {
if ( defined $categorycode_conversions{ $borrower{categorycode} } ) {
$borrower{categorycode} = $categorycode_conversions{ $borrower{categorycode} };
} elsif ($default_categorycode) {
$borrower{categorycode} = $default_categorycode;
}
# check if categorycode exists, if not, fallback to default from koha-conf.xml
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT categorycode FROM categories WHERE categorycode = ?");
$sth->execute( uc($borrower{'categorycode'}) );
$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,13 +363,15 @@ 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->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;
( $sth->rows == 1 ) and return $sth->fetchrow;
return 0;
}
@ -373,30 +385,27 @@ sub exists_local {
# Note: if the LDAP config has the update_password tag set to a false value,
# then this will not update the password, it will simply return the cardnumber.
sub _do_changepassword {
my ($userid, $borrowerid, $password) = @_;
my ( $userid, $borrowerid, $password ) = @_;
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 });
my ($ok, $cardnum) = checkpw_internal($userid, $password);
#warn "changing local password for borrowernumber=$borrowerid to '$digest'\n";
Koha::Patrons->find($borrowerid)->set_password( { password => $password, skip_validation => 1 } );
my ( $ok, $cardnum ) = checkpw_internal( $userid, $password );
return $cardnum if $ok;
warn "Password mismatch after update to borrowernumber=$borrowerid";
@ -411,29 +420,27 @@ sub update_local {
# skip extended patron attributes in 'borrowers' attribute update
my @keys = keys %$borrower;
if (C4::Context->preference('ExtendedPatronAttributes')) {
if ( C4::Context->preference('ExtendedPatronAttributes') ) {
my $library_id = C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef;
my $attribute_types = Koha::Patron::Attribute::Types->search_with_library_limits({}, {}, $library_id);
my $attribute_types = Koha::Patron::Attribute::Types->search_with_library_limits( {}, {}, $library_id );
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'} );
_do_changepassword( $userid, $borrowerid, $password ) if exists( $borrower->{'password'} );
}
1;

60
C4/Auth_with_shibboleth.pm
View File

@ -30,12 +30,12 @@ use List::MoreUtils qw( any );
use Koha::Logger;
our (@ISA, @EXPORT_OK);
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
@ -70,12 +70,12 @@ sub login_shib_url {
# Returns shibboleth user login
sub get_login_shib {
# In case of a Shibboleth authentication, we expect a shibboleth user attribute
# to contain the login match point of the shibboleth-authenticated user. This match
# point is configured in koha-conf.xml
# In case of a Shibboleth authentication, we expect a shibboleth user attribute
# to contain the login match point of the shibboleth-authenticated user. This match
# point is configured in koha-conf.xml
# Shibboleth attributes are mapped into http environmement variables, so we're getting
# the match point of the user this way
# Shibboleth attributes are mapped into http environmement variables, so we're getting
# the match point of the user this way
# Get shibboleth config
my $config = _get_shib_config();
@ -83,7 +83,7 @@ sub get_login_shib {
my $matchAttribute = $config->{mapping}->{ $config->{matchpoint} }->{is};
if ( C4::Context->psgi_env ) {
return $ENV{"HTTP_".uc($matchAttribute)} || '';
return $ENV{ "HTTP_" . uc($matchAttribute) } || '';
} else {
return $ENV{$matchAttribute} || '';
}
@ -93,21 +93,23 @@ sub get_login_shib {
# In our case : does the given attribute match one of our users ?
sub checkpw_shib {
my ( $match ) = @_;
my ($match) = @_;
my $config = _get_shib_config();
# 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 ( $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;
if ( defined($borrower) ) {
if ($config->{'sync'}) {
_sync($borrower->borrowernumber, $config, $match);
if ( $config->{'sync'} ) {
_sync( $borrower->borrowernumber, $config, $match );
}
return ( 1, $borrower->get_column('cardnumber'), $borrower->get_column('userid'), $borrower );
}
@ -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;
@ -126,9 +129,9 @@ sub _autocreate {
my %borrower = ( $config->{matchpoint} => $match );
while ( my ( $key, $entry ) = each %{$config->{'mapping'}} ) {
while ( my ( $key, $entry ) = each %{ $config->{'mapping'} } ) {
if ( C4::Context->psgi_env ) {
$borrower{$key} = ( $entry->{'is'} && $ENV{"HTTP_" . uc($entry->{'is'}) } ) || $entry->{'content'} || '';
$borrower{$key} = ( $entry->{'is'} && $ENV{ "HTTP_" . uc( $entry->{'is'} ) } ) || $entry->{'content'} || '';
} else {
$borrower{$key} = ( $entry->{'is'} && $ENV{ $entry->{'is'} } ) || $entry->{'content'} || '';
}
@ -178,18 +181,18 @@ sub _autocreate {
}
sub _sync {
my ($borrowernumber, $config, $match ) = @_;
my ( $borrowernumber, $config, $match ) = @_;
my %borrower;
$borrower{'borrowernumber'} = $borrowernumber;
while ( my ( $key, $entry ) = each %{$config->{'mapping'}} ) {
while ( my ( $key, $entry ) = each %{ $config->{'mapping'} } ) {
if ( C4::Context->psgi_env ) {
$borrower{$key} = ( $entry->{'is'} && $ENV{"HTTP_" . uc($entry->{'is'}) } ) || $entry->{'content'} || '';
$borrower{$key} = ( $entry->{'is'} && $ENV{ "HTTP_" . uc( $entry->{'is'} ) } ) || $entry->{'content'} || '';
} else {
$borrower{$key} = ( $entry->{'is'} && $ENV{ $entry->{'is'} } ) || $entry->{'content'} || '';
}
}
my $patron = Koha::Patrons->find( $borrowernumber );
$patron->set(\%borrower)->store;
my $patron = Koha::Patrons->find($borrowernumber);
$patron->set( \%borrower )->store;
}
sub _get_uri {
@ -206,9 +209,9 @@ sub _get_uri {
$uri ||= "";
if ($uri =~ /(.*):\/\/(.*)/) {
if ( $uri =~ /(.*):\/\/(.*)/ ) {
my $oldprotocol = $1;
if ($oldprotocol ne 'https') {
if ( $oldprotocol ne 'https' ) {
Koha::Logger->get->warn('Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!');
}
$uri = $2;
@ -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);
@ -250,15 +254,13 @@ sub _get_shib_config {
&& defined( $config->{mapping}->{ $config->{matchpoint} }->{is} ) )
{
my $logger = Koha::Logger->get;
$logger->debug("koha borrower field to match: " . $config->{matchpoint});
$logger->debug("shibboleth attribute to match: " . $config->{mapping}->{ $config->{matchpoint} }->{is});
$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;

866
C4/AuthoritiesMarc.pm
View File

File diff suppressed because it is too large Load Diff

12
C4/AuthoritiesMarc/MARC21.pm
View File

@ -64,7 +64,7 @@ this defaults to 942$a.
=cut
sub default_auth_type_location {
return ('942', 'a');
return ( '942', 'a' );
}
=head2 fix_marc21_auth_type_location
@ -91,13 +91,13 @@ FIXME: This function should be removed once it's determined
=cut
sub fix_marc21_auth_type_location {
my ($auth_marc, $auth_type_tag, $auth_type_subfield) = @_;
my ( $auth_marc, $auth_type_tag, $auth_type_subfield ) = @_;
my $auth_type_code;
return unless $auth_type_code = $auth_marc->subfield('152', 'b');
$auth_marc->delete_field($auth_marc->field('152'));
unless ($auth_marc->field($auth_type_tag) && $auth_marc->subfield($auth_type_tag, $auth_type_subfield)) {
$auth_marc->add_fields($auth_type_tag,'','', $auth_type_subfield=>$auth_type_code);
return unless $auth_type_code = $auth_marc->subfield( '152', 'b' );
$auth_marc->delete_field( $auth_marc->field('152') );
unless ( $auth_marc->field($auth_type_tag) && $auth_marc->subfield( $auth_type_tag, $auth_type_subfield ) ) {
$auth_marc->add_fields( $auth_type_tag, '', '', $auth_type_subfield => $auth_type_code );
}
}

2
C4/AuthoritiesMarc/UNIMARC.pm
View File

@ -64,7 +64,7 @@ this defaults to 152$b.
=cut
sub default_auth_type_location {
return ('152', 'b');
return ( '152', 'b' );
}
=head1 AUTHOR

68
C4/Barcodes.pm
View File

@ -31,8 +31,8 @@ use C4::Barcodes::EAN13;
use vars qw($max $prefformat);
sub _prefformat {
unless (defined $prefformat) {
unless ($prefformat = C4::Context->preference('autoBarcode')) {
unless ( defined $prefformat ) {
unless ( $prefformat = C4::Context->preference('autoBarcode') ) {
carp "The autoBarcode syspref is missing/undefined. Assuming 'incremental'.";
$prefformat = 'incremental';
}
@ -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,22 +83,25 @@ 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;
unless ($barcode =~ /(.*?)(\d+)$/) { # non-greedy match in first part
unless ( $barcode =~ /(.*?)(\d+)$/ ) { # non-greedy match in first part
carp "Barcode '$barcode' has no incrementing part!";
return ($barcode,undef,undef);
return ( $barcode, undef, undef );
}
return ($1,$2,''); # the third part is in anticipation of barcodes that include checkdigits
return ( $1, $2, '' ); # the third part is in anticipation of barcodes that include checkdigits
}
sub max {
my $self = shift;
if ($self->{is_max}) {
if ( $self->{is_max} ) {
return $self->value;
}
return $self->db_max;
}
sub db_max {
my $self = shift;
my $query = "SELECT max(abs(CAST(barcode AS UNSIGNED))) FROM items LIMIT 1"
@ -101,16 +110,17 @@ sub db_max {
$sth->execute();
return $sth->fetchrow_array || $self->initial;
}
sub next_value {
my $self = shift;
my $specific = (scalar @_) ? 1 : 0;
my $specific = ( scalar @_ ) ? 1 : 0;
my $max = $specific ? shift : $self->max; # optional argument, i.e. next_value after X
unless ($max) {
warn "No max barcode ($self->autoBarcode format) found. Using initial value.";
return $self->initial;
}
my ($head,$incr,$tail) = $self->parse($max); # for incremental, you'd get ('',the_whole_barcode,'')
unless (defined $incr) {
my ( $head, $incr, $tail ) = $self->parse($max); # for incremental, you'd get ('',the_whole_barcode,'')
unless ( defined $incr ) {
warn "No incrementing part of barcode ($max) returned by parse.";
return;
}
@ -120,26 +130,30 @@ sub next_value {
# Those should override next_value() to work accordingly.
$incr++;
$head = $self->process_head($head,$max,$specific);
$tail = $self->process_tail($tail,$incr,$specific); # XXX use $incr and not $max!
$head = $self->process_head( $head, $max, $specific );
$tail = $self->process_tail( $tail, $incr, $specific ); # XXX use $incr and not $max!
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;
@ -155,11 +169,11 @@ sub default_self {
}
our $types = {
annual => sub {C4::Barcodes::annual->new_object(@_); },
incremental => sub {C4::Barcodes::incremental->new_object(@_);},
hbyymmincr => sub {C4::Barcodes::hbyymmincr->new_object(@_); },
OFF => sub {C4::Barcodes::OFF->new_object(@_); },
EAN13 => sub {C4::Barcodes::EAN13->new_object(@_); },
annual => sub { C4::Barcodes::annual->new_object(@_); },
incremental => sub { C4::Barcodes::incremental->new_object(@_); },
hbyymmincr => sub { C4::Barcodes::hbyymmincr->new_object(@_); },
OFF => sub { C4::Barcodes::OFF->new_object(@_); },
EAN13 => sub { C4::Barcodes::EAN13->new_object(@_); },
};
sub new {
@ -172,30 +186,32 @@ sub new {
carp "No autoBarcode format found.";
return;
}
unless (defined $types->{$autoBarcodeType}) {
unless ( defined $types->{$autoBarcodeType} ) {
carp "The autoBarcode format '$autoBarcodeType' is unrecognized.";
return;
}
my $self;
if ($autoBarcodeType eq 'OFF') {
if ( $autoBarcodeType eq 'OFF' ) {
$self = $class_or_object->default_self($autoBarcodeType);
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) {
$self->serial( $class_or_object->serial + 1 );
if ( $class_or_object->is_max ) {
$self->previous($class_or_object);
$class_or_object->next($self);
$self->value($self->next_value($class_or_object->value));
$self->value( $self->next_value( $class_or_object->value ) );
$self->is_max(1) and $class_or_object->is_max(0); # new object is max, old object is no longer max
} else {
$self->value($self->next_value);
$self->value( $self->next_value );
}
} else {
$self = &{$types->{$autoBarcodeType}} (@_);
$self->value($self->next_value) and $self->is_max(1);
$self = &{ $types->{$autoBarcodeType} }(@_);
$self->value( $self->next_value ) and $self->is_max(1);
$self->serial(1);
}
if ($self) {
@ -209,7 +225,7 @@ sub new_object {
my $class_or_object = shift;
my $type = ref($class_or_object) || $class_or_object;
my $from_obj = ref($class_or_object) ? 1 : 0; # are we building off another Barcodes object?
my $self = $class_or_object->default_self($from_obj ? $class_or_object->autoBarcode : 'incremental');
my $self = $class_or_object->default_self( $from_obj ? $class_or_object->autoBarcode : 'incremental' );
bless $self, $type;
return $self;
}

2
C4/Barcodes/EAN13.pm
View File

@ -44,7 +44,7 @@ sub parse {
}
sub process_tail {
my ( $self,$tail,$whole,$specific ) = @_;
my ( $self, $tail, $whole, $specific ) = @_;
my $ean = CheckDigits('ean');
my $full = $ean->complete($whole);
my $chk = $ean->checkdigit($full);

19
C4/Barcodes/ValueBuilder.pm
View File

@ -25,11 +25,12 @@ 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);
$sth->execute();
while (my ($count)= $sth->fetchrow_array) {
while ( my ($count) = $sth->fetchrow_array ) {
$nextnum = $count;
}
$nextnum++;
@ -44,17 +45,17 @@ use C4::Context;
sub get_barcode {
my ($args) = @_;
my $nextnum = 0;
my $year = substr($args->{year}, -2);
my $year = substr( $args->{year}, -2 );
my $month = $args->{mon};
my $query = "SELECT MAX(CAST(SUBSTRING(barcode,-4) AS signed)) AS number FROM items WHERE barcode REGEXP ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute("^[-a-zA-Z]{1,}$year$month");
while (my ($count)= $sth->fetchrow_array) {
while ( my ($count) = $sth->fetchrow_array ) {
$nextnum = $count if $count;
$nextnum = 0 if $nextnum == 9999; # this sequence only allows for cataloging 9999 items per month
}
$nextnum++;
$nextnum = sprintf("%0*d", "4",$nextnum);
$nextnum = sprintf( "%0*d", "4", $nextnum );
$nextnum = $year . $month . $nextnum;
my $scr = qq~
let elt = \$("#"+id);
@ -73,7 +74,6 @@ sub get_barcode {
return $nextnum, $scr;
}
package C4::Barcodes::ValueBuilder::annual;
use C4::Context;
@ -81,20 +81,19 @@ sub get_barcode {
my ($args) = @_;
my $nextnum;
my $query = "select max(cast( substring_index(barcode, '-',-1) as signed)) from items where barcode like ?";
my $sth=C4::Context->dbh->prepare($query);
$sth->execute($args->{year} . '-%');
while (my ($count)= $sth->fetchrow_array) {
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( $args->{year} . '-%' );
while ( my ($count) = $sth->fetchrow_array ) {
$nextnum = $count if $count;
}
$nextnum++;
$nextnum = sprintf("%0*d", "4",$nextnum);
$nextnum = sprintf( "%0*d", "4", $nextnum );
$nextnum = "$args->{year}-$nextnum";
return $nextnum;
}
1;
=head1 Barcodes::ValueBuilder
This module is intended as a shim to ease the eventual transition from

31
C4/Barcodes/annual.pm
View File

@ -37,21 +37,24 @@ 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
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # failover back to today
}
} else {
$iso = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } );
}
my $year = substr($iso,0,4); # YYYY
my $year = substr( $iso, 0, 4 ); # YYYY
$sth->execute("$year-%");
my $row = $sth->fetchrow_hashref;
return $row->{barcode};
@ -59,27 +62,33 @@ 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 {
my $self = shift;
my $barcode = (@_) ? shift : $self->value;
unless ($barcode =~ /(\d{4}-)(\d+)$/) { # non-greedy match in first part
unless ( $barcode =~ /(\d{4}-)(\d+)$/ ) { # non-greedy match in first part
carp "Barcode '$barcode' has no incrementing part!";
return ($barcode,undef,undef);
return ( $barcode, undef, undef );
}
return ($1,$2,''); # the third part is in anticipation of barcodes that include checkdigits
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) = @_;
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 {

38
C4/Barcodes/hbyymmincr.pm
View File

@ -40,49 +40,53 @@ 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
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # failover back to today
}
} else {
$iso = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
$iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } );
}
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.
unless ($sth->rows) {
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.
unless ( $sth->rows ) {
warn "No existing hbyymmincr barcodes found. Reverting to initial value.";
return $self->initial;
}
my ($row) = $sth->fetchrow_hashref;
my $max = $row->{barcode};
return ($max || 0);
return ( $max || 0 );
}
sub initial {
my $self = shift;
# FIXME: populated branch?
my $iso = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }); # like "2008-07-02"
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 '' );
my $width = WIDTH;
return $self->branch . substr($iso,2,2) . substr($iso,5,2) . sprintf('%' . "$width.$width" . 'd',1);
return $self->branch . substr( $iso, 2, 2 ) . substr( $iso, 5, 2 ) . sprintf( '%' . "$width.$width" . 'd', 1 );
}
sub parse { # return 3 parts of barcode: non-incrementing, incrementing, non-incrementing
my $self = shift;
my $barcode = (@_) ? shift : $self->value;
my $branch = $self->branch;
unless ($barcode =~ /($branch\d{4})(\d+)$/) {
unless ( $barcode =~ /($branch\d{4})(\d+)$/ ) {
carp "Barcode '$barcode' has no incrementing part!";
return ($barcode,undef,undef);
return ( $barcode, undef, undef );
}
return ($1,$2,''); # the third part is in anticipation of barcodes that include checkdigits
return ( $1, $2, '' ); # the third part is in anticipation of barcodes that include checkdigits
}
sub branch {
@ -99,11 +103,11 @@ sub branch {
#}
sub process_head { # (self,head,whole,specific)
my ($self,$head,$whole,$specific) = @_;
my ( $self, $head, $whole, $specific ) = @_;
$specific and return $head; # if this is built off an existing barcode, just return the head unchanged.
$head =~ s/\d{4}$//; # else strip the old yymm
my $iso = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }); # like "2008-07-02"
return $head . substr($iso,2,2) . substr($iso,5,2);
my $iso = output_pref( { dt => dt_from_string, dateformat => 'iso', dateonly => 1 } ); # like "2008-07-02"
return $head . substr( $iso, 2, 2 ) . substr( $iso, 5, 2 );
}
sub new_object {

716
C4/Biblio.pm
View File

File diff suppressed because it is too large Load Diff

324
C4/Breeding.pm
View File

@ -32,7 +32,8 @@ use C4::Languages;
use Koha::Database;
use Koha::XSLT::Base;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -69,7 +70,7 @@ sub BreedingSearch {
my ($term) = @_;
my $dbh = C4::Context->dbh;
my $count = 0;
my ($query,@bind);
my ( $query, @bind );
my $sth;
my @results;
@ -88,12 +89,13 @@ sub BreedingSearch {
FROM import_biblios
JOIN import_records USING (import_record_id)
JOIN import_batches USING (import_batch_id)
WHERE title LIKE ? OR author LIKE ? OR isbn IN (" . join(',',('?') x @isbns) . ")";
@bind=( $authortitle, $authortitle, @isbns );
WHERE title LIKE ? OR author LIKE ? OR isbn IN (" . join( ',', ('?') x @isbns ) . ")";
@bind = ( $authortitle, $authortitle, @isbns );
$sth = $dbh->prepare($query);
$sth->execute(@bind);
while (my $data = $sth->fetchrow_hashref) {
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
@ -104,10 +106,9 @@ sub BreedingSearch {
} # while
$sth->finish;
return($count, @results);
return ( $count, @results );
} # sub breedingsearch
=head2 Z3950Search
Z3950Search($pars, $template);
@ -120,11 +121,11 @@ The second parameter $template is a Template object. The routine uses this param
=cut
sub Z3950Search {
my ($pars, $template)= @_;
my ( $pars, $template ) = @_;
my @id= @{$pars->{id}};
my $page= $pars->{page};
my $biblionumber= $pars->{biblionumber};
my @id = @{ $pars->{id} };
my $page = $pars->{page};
my $biblionumber = $pars->{biblionumber};
my $show_next = 0;
my $total_pages = 0;
@ -134,27 +135,26 @@ sub Z3950Search {
my @oResult;
my @errconn;
my $s = 0;
my $imported=0;
my $imported = 0;
my ( $zquery, $squery ) = _bib_build_query( $pars );
my ( $zquery, $squery ) = _bib_build_query($pars);
my $schema = Koha::Database->new()->schema();
my $rs = $schema->resultset('Z3950server')->search(
{ id => [ @id ] },
{ id => [@id] },
{ result_class => 'DBIx::Class::ResultClass::HashRefInflator' },
);
my @servers = $rs->all;
foreach my $server ( @servers ) {
foreach my $server (@servers) {
my $server_zquery = $zquery;
if(my $attributes = $server->{attributes}){
if ( my $attributes = $server->{attributes} ) {
$server_zquery = "$attributes $zquery";
}
$oConnection[$s] = _create_connection( $server );
$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;
@ -170,28 +170,40 @@ sub Z3950Search {
if ( $k != 0 ) {
$k--;
my ($error)= $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset
my ($error) = $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset
if ($error) {
if ($error =~ m/^(10000|10007)$/ ) {
push(@errconn, { server => $servers[$k]->{host}, error => $error } );
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++) {
if ( $numresults > 0 and $numresults >= ( ( $page - 1 ) * 20 ) ) {
$show_next = 1 if $numresults >= ( $page * 20 );
$total_pages = int( $numresults / 20 ) + 1 if $total_pages < ( $numresults / 20 );
for (
$i = ( $page - 1 ) * 20 ;
$i < ( ( $numresults < ( $page * 20 ) ) ? $numresults : ( $page * 20 ) ) ;
$i++
)
{
if ( $oResult[$k]->record($i) ) {
undef $error;
( $res, $error ) = _handle_one_result( $oResult[$k]->record($i), $servers[$k], ++$imported, $biblionumber, $xslh ); #ignores error in sequence numbering
( $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
@ -202,13 +214,13 @@ sub Z3950Search {
numberpending => $nremaining,
current_page => $page,
total_pages => $total_pages,
show_nextbutton => $show_next?1:0,
show_prevbutton => $page!=1,
show_nextbutton => $show_next ? 1 : 0,
show_prevbutton => $page != 1,
);
} # while nremaining
#close result sets and connections
foreach(0..$s-1) {
foreach ( 0 .. $s - 1 ) {
$oResult[$_]->destroy();
$oConnection[$_]->destroy();
}
@ -221,7 +233,7 @@ sub Z3950Search {
}
sub _auth_build_query {
my ( $pars ) = @_;
my ($pars) = @_;
my $qry_build = {
nameany => '@attr 1=1002 "#term" ',
@ -242,7 +254,7 @@ sub _auth_build_query {
sub _bib_build_query {
my ( $pars ) = @_;
my ($pars) = @_;
my $qry_build = {
isbn => '@attr 1=7 @attr 5=1 "#term" ',
@ -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" ',
@ -266,54 +277,63 @@ sub _build_query {
my ( $pars, $qry_build ) = @_;
my $zquery='';
my $squery='';
my $nterms=0;
my $zquery = '';
my $squery = '';
my $nterms = 0;
foreach my $k ( sort keys %$pars ) {
#note that the sort keys forces an identical result under Perl 5.18
#one of the unit tests is based on that assumption
if( ( my $val=$pars->{$k} ) && $qry_build->{$k} ) {
if ( ( my $val = $pars->{$k} ) && $qry_build->{$k} ) {
$qry_build->{$k} =~ s/#term/$val/g;
$zquery .= $qry_build->{$k};
$squery .= "[$k]=\"$val\" and ";
$nterms++;
}
}
$zquery = "\@and " . $zquery for 2..$nterms;
$zquery = "\@and " . $zquery for 2 .. $nterms;
$squery =~ s/ and $//;
return ( $zquery, $squery );
}
sub _handle_one_result {
my ( $zoomrec, $servhref, $seq, $bib, $xslh )= @_;
my ( $zoomrec, $servhref, $seq, $bib, $xslh ) = @_;
my $raw= $zoomrec->raw();
my $raw = $zoomrec->raw();
my $marcrecord;
if( $servhref->{servertype} eq 'sru' ) {
$marcrecord= MARC::Record->new_from_xml( $raw, 'UTF-8',
$servhref->{syntax} );
if ( $servhref->{servertype} eq 'sru' ) {
$marcrecord = MARC::Record->new_from_xml(
$raw, 'UTF-8',
$servhref->{syntax}
);
$marcrecord->encoding('UTF-8');
} else {
($marcrecord) = MarcToUTF8Record($raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" ); #ignores charset return values
($marcrecord) =
MarcToUTF8Record( $raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" )
; #ignores charset return values
}
SetUTF8Flag($marcrecord);
my $error;
( $marcrecord, $error ) = _do_xslt_proc($marcrecord, $servhref, $xslh);
( $marcrecord, $error ) = _do_xslt_proc( $marcrecord, $servhref, $xslh );
my $batch_id = GetZ3950BatchId( $servhref->{servername} );
my $breedingid = AddBiblioToBatch( $batch_id, $seq, $marcrecord, 'UTF-8', 0 );
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' });
if ($breedingid) {
my @kohafields =
( 'biblio.title', 'biblio.author', 'biblioitems.isbn', 'biblioitems.lccn', 'biblioitems.editionstatement' );
push @kohafields,
C4::Context->preference('marcflavour') eq "MARC21" ? 'biblio.copyrightdate' : 'biblioitems.publicationyear';
$row = C4::Biblio::TransformMarcToKoha(
{ record => $marcrecord, kohafields => \@kohafields, limit_table => 'no_items' } );
$row->{date} = $row->{copyrightdate} // $row->{publicationyear};
$row->{biblionumber} = $bib;
$row->{server} = $servhref->{servername};
$row->{breedingid} = $breedingid;
$row->{isbn}=_isbn_replace($row->{isbn});
$row->{isbn} = _isbn_replace( $row->{isbn} );
my $pref_newtags = C4::Context->preference('AdditionalFieldsInZ3950ResultSearch');
$row = _add_custom_field_rowdata( $row, $marcrecord, $pref_newtags );
}
@ -328,24 +348,24 @@ sub _do_xslt_proc {
my $theme = C4::Context->preference("template"); #staff
my $lang = C4::Languages::getlanguage() || 'en';
my @files= split ',', $server->{add_xslt};
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 =~ /^\//;
foreach my $f (@files) {
$f =~ s/^\s+//;
$f =~ s/\s+$//;
next if !$f;
$f = C4::XSLT::_get_best_default_xslt_filename( $htdocs, $theme, $lang, $f ) unless $f =~ /^\//;
$xml = $xslh->transform( $xml, $f );
last if $xslh->err; #skip other files
}
if( !$xslh->err ) {
return MARC::Record->new_from_xml($xml, 'UTF-8');
if ( !$xslh->err ) {
return MARC::Record->new_from_xml( $xml, 'UTF-8' );
} else {
return ( $marc, $xslh->err ); #original record in case of errors
}
}
sub _add_custom_field_rowdata
{
sub _add_custom_field_rowdata {
my ( $row, $record, $pref_newtags ) = @_;
$pref_newtags //= '';
my $pref_flavour = C4::Context->preference('MarcFlavour');
@ -355,22 +375,22 @@ sub _add_custom_field_rowdata
my @addnumberfields;
foreach my $field (split /\,/, $pref_newtags) {
$field =~ s/^\s+|\s+$//g ; # trim whitespace
my ($tag, $subtags) = split(/\$/, $field);
foreach my $field ( split /\,/, $pref_newtags ) {
$field =~ s/^\s+|\s+$//g; # trim whitespace
my ( $tag, $subtags ) = split( /\$/, $field );
if ( $record->field($tag) ) {
my @content = ();
for my $marcfield ($record->field($tag)) {
if ( $subtags ) {
for my $marcfield ( $record->field($tag) ) {
if ($subtags) {
my $str = '';
for my $code (split //, $subtags) {
for my $code ( split //, $subtags ) {
if ( $marcfield->subfield($code) ) {
$str .= $marcfield->subfield($code) . ' ';
}
}
if ( not $str eq '') {
if ( not $str eq '' ) {
push @content, $str;
}
} elsif ( $tag == 10 ) {
@ -382,7 +402,7 @@ sub _add_custom_field_rowdata
}
}
if ( @content ) {
if (@content) {
$row->{$field} = \@content;
push( @addnumberfields, $field );
}
@ -404,36 +424,38 @@ sub _isbn_replace {
}
sub _create_connection {
my ( $server ) = @_;
my $option1= ZOOM::Options->new();
my ($server) = @_;
my $option1 = ZOOM::Options->new();
$option1->option( 'async' => 1 );
$option1->option( 'elementSetName', 'F' );
$option1->option( 'preferredRecordSyntax', $server->{syntax} );
$option1->option( 'timeout', $server->{timeout} ) if $server->{timeout};
if( $server->{servertype} eq 'sru' ) {
foreach( split ',', $server->{sru_options}//'' ) {
if ( $server->{servertype} eq 'sru' ) {
foreach ( split ',', $server->{sru_options} // '' ) {
#first remove surrounding spaces at comma and equals-sign
s/^\s+|\s+$//g;
my @temp= split '=', $_, 2;
@temp= map { my $c=$_; $c=~s/^\s+|\s+$//g; $c; } @temp;
my @temp = split '=', $_, 2;
@temp = map { my $c = $_; $c =~ s/^\s+|\s+$//g; $c; } @temp;
$option1->option( $temp[0] => $temp[1] ) if @temp;
}
} elsif( $server->{servertype} eq 'zed' ) {
} elsif ( $server->{servertype} eq 'zed' ) {
$option1->option( 'databaseName', $server->{db} );
$option1->option( 'user', $server->{userid} ) if $server->{userid};
$option1->option( 'password', $server->{password} ) if $server->{password};
}
my $obj= ZOOM::Connection->create($option1);
if( $server->{servertype} eq 'sru' ) {
my $host= $server->{host};
if( $host !~ /^https?:\/\// ) {
my $obj = ZOOM::Connection->create($option1);
if ( $server->{servertype} eq 'sru' ) {
my $host = $server->{host};
if ( $host !~ /^https?:\/\// ) {
#Normally, host will not be prefixed by protocol.
#In that case we can (safely) assume http.
#In case someone prefixed with https, give it a try..
$host = 'http://' . $host;
}
$obj->connect( $host.':'.$server->{port}.'/'.$server->{db} );
$obj->connect( $host . ':' . $server->{port} . '/' . $server->{db} );
} else {
$obj->connect( $server->{host}, $server->{port} );
}
@ -441,24 +463,27 @@ sub _create_connection {
}
sub _translate_query { #SRU query adjusted per server cf. srufields column
my ($server, $query) = @_;
my ( $server, $query ) = @_;
#sru_fields is in format title=field,isbn=field,...
#if a field doesn't exist, try anywhere or remove [field]=
my @parts= split(',', $server->{sru_fields} );
my %trans= map { if( /=/ ) { ( $`,$' ) } else { () } } @parts;
my $any= $trans{srchany}?$trans{srchany}.'=':'';
my @parts = split( ',', $server->{sru_fields} );
my %trans = map {
if (/=/) { ( $`, $' ) }
else { () }
} @parts;
my $any = $trans{srchany} ? $trans{srchany} . '=' : '';
my $q=$query;
foreach my $key (keys %trans) {
my $f=$trans{$key};
if( $f ) {
$q=~s/\[$key\]/$f/g;
my $q = $query;
foreach my $key ( keys %trans ) {
my $f = $trans{$key};
if ($f) {
$q =~ s/\[$key\]/$f/g;
} else {
$q=~s/\[$key\]=/$any/g;
$q =~ s/\[$key\]=/$any/g;
}
}
$q=~s/\[\w+\]=/$any/g; # remove remaining fields (not found in field list)
$q =~ s/\[\w+\]=/$any/g; # remove remaining fields (not found in field list)
return $q;
}
@ -475,15 +500,16 @@ 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;
$searchbreeding->execute($controlnumber,$heading);
$searchbreeding->execute( $controlnumber, $heading );
my ($breedingid) = $searchbreeding->fetchrow;
return $breedingid if $breedingid;
$breedingid = AddAuthToBatch($batch_id, 0, $marcrecord, $encoding);
$breedingid = AddAuthToBatch( $batch_id, 0, $marcrecord, $encoding );
return $breedingid;
}
@ -500,12 +526,11 @@ The second parameter $template is a Template object. The routine uses this param
=cut
sub Z3950SearchAuth {
my ($pars, $template)= @_;
my ( $pars, $template ) = @_;
my $dbh = C4::Context->dbh;
my @id= @{$pars->{id}};
my $page= $pars->{page} // 1;
my @id = @{ $pars->{id} };
my $page = $pars->{page} // 1;
my $show_next = 0;
my $total_pages = 0;
@ -518,31 +543,29 @@ sub Z3950SearchAuth {
my @servers;
my $s = 0;
my $query;
my $nterms=0;
my $nterms = 0;
my $marcflavour = C4::Context->preference('marcflavour');
my $marc_type = $marcflavour eq 'UNIMARC' ? 'UNIMARCAUTH' : $marcflavour;
my $authid= $pars->{authid};
my ( $zquery, $squery ) = _auth_build_query( $pars );
my $authid = $pars->{authid};
my ( $zquery, $squery ) = _auth_build_query($pars);
foreach my $servid (@id) {
my $sth = $dbh->prepare("select * from z3950servers where id=?");
$sth->execute($servid);
while ( my $server = $sth->fetchrow_hashref ) {
$oConnection[$s] = _create_connection( $server );
$oConnection[$s] = _create_connection($server);
if ( $server->{servertype} eq 'zed' ) {
my $server_zquery = $zquery;
if ( my $attributes = $server->{attributes} ) {
$server_zquery = "$attributes $zquery";
}
$oResult[$s] = $oConnection[$s]->search_pqf( $server_zquery );
$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");
$encoding[$s] = ( $server->{encoding} ? $server->{encoding} : "iso-5426" );
$servers[$s] = $server;
$s++;
} ## while fetch
@ -559,35 +582,44 @@ sub Z3950SearchAuth {
if ( $k != 0 ) {
$k--;
my ($error )= $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset
my ($error) = $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset
if ($error) {
if ($error =~ m/^(10000|10007)$/ ) {
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++) {
if ( $numresults > 0 and $numresults >= ( ( $page - 1 ) * 20 ) ) {
$show_next = 1 if $numresults >= ( $page * 20 );
$total_pages = int( $numresults / 20 ) + 1 if $total_pages < ( $numresults / 20 );
for (
$i = ( $page - 1 ) * 20 ;
$i < ( ( $numresults < ( $page * 20 ) ) ? $numresults : ( $page * 20 ) ) ;
$i++
)
{
my $rec = $oResult[$k]->record($i);
if ($rec) {
my $marcdata = $rec->raw();
my $marcrecord;
if( $servers[$k]->{servertype} eq 'sru' ) {
$marcrecord = eval { MARC::Record->new_from_xml( $marcdata, 'UTF-8', $servers[$k]->{syntax} ) };
if( !$marcrecord || $@ ) {
if ( $servers[$k]->{servertype} eq 'sru' ) {
$marcrecord =
eval { MARC::Record->new_from_xml( $marcdata, 'UTF-8', $servers[$k]->{syntax} ) };
if ( !$marcrecord || $@ ) {
_dump_conversion_error( $servers[$k]->{servername}, $marcdata, $@ );
next; # skip this one
}
} else {
my ($charset_result, $charset_errors);
( $marcrecord, $charset_result, $charset_errors ) = MarcToUTF8Record( $marcdata, $marc_type, $encoding[$k] );
if( !$marcrecord || @$charset_errors ) {
_dump_conversion_error( $servers[$k]->{servername}, $marcdata, $charset_result, $charset_errors );
my ( $charset_result, $charset_errors );
( $marcrecord, $charset_result, $charset_errors ) =
MarcToUTF8Record( $marcdata, $marc_type, $encoding[$k] );
if ( !$marcrecord || @$charset_errors ) {
_dump_conversion_error(
$servers[$k]->{servername}, $marcdata, $charset_result,
$charset_errors
);
next; # skip this one
}
}
@ -595,7 +627,7 @@ sub Z3950SearchAuth {
SetUTF8Flag($marcrecord);
my $heading_authtype_code = GuessAuthTypeCode($marcrecord) or next;
my $heading = GetAuthorizedHeading({ record => $marcrecord });
my $heading = GetAuthorizedHeading( { record => $marcrecord } );
my $breedingid = ImportBreedingAuth( $marcrecord, $servers[$k]->{host}, 'UTF-8', $heading );
my %row_data;
$row_data{server} = $servers[$k]->{'servername'};
@ -604,13 +636,19 @@ sub Z3950SearchAuth {
$row_data{authid} = $authid;
$row_data{heading_code} = $heading_authtype_code;
$row_data{row} = _add_custom_field_rowdata(
{ %row_data }, $marcrecord,
{%row_data}, $marcrecord,
C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch')
) if C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch');
push( @breeding_loop, \%row_data );
} else {
push(
@breeding_loop,
{
'server' => $servers[$k]->{'servername'},
'title' => join( ': ', $oConnection[$k]->error_x() ), 'breedingid' => -1,
'authid' => -1
}
else {
push(@breeding_loop,{'server'=>$servers[$k]->{'servername'},'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1,'authid'=>-1});
);
}
}
} #if $numresults
@ -621,20 +659,20 @@ sub Z3950SearchAuth {
numberpending => $nremaining,
current_page => $page,
total_pages => $total_pages,
show_nextbutton => $show_next?1:0,
show_prevbutton => $page!=1,
show_nextbutton => $show_next ? 1 : 0,
show_prevbutton => $page != 1,
);
} # while nremaining
#close result sets and connections
foreach(0..$s-1) {
foreach ( 0 .. $s - 1 ) {
$oResult[$_]->destroy();
$oConnection[$_]->destroy();
}
@servers = ();
foreach my $id (@id) {
push @servers, {id => $id};
push @servers, { id => $id };
}
$template->param(
breeding_loop => \@breeding_loop,
@ -645,7 +683,7 @@ sub Z3950SearchAuth {
sub _dump_conversion_error {
require Data::Dumper;
warn Data::Dumper->new([ 'Z3950SearchAuth conversion error', @_ ])->Indent(0)->Dump;
warn Data::Dumper->new( [ 'Z3950SearchAuth conversion error', @_ ] )->Indent(0)->Dump;
}
1;

462
C4/Budgets.pm
View File

File diff suppressed because it is too large Load Diff

226
C4/Calendar.pm
View File

@ -54,12 +54,13 @@ C<$branchcode> specifies which Calendar you want.
sub new {
my $classname = shift @_;
my %options = @_;
my $self = bless({}, $classname);
foreach my $optionName (keys %options) {
$self->{lc($optionName)} = $options{$optionName};
my $self = bless( {}, $classname );
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)";
$self->_init($self->{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,51 +69,56 @@ 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) = ?)' );
$repeatable->execute($branch,0);
AND (ISNULL(weekday) = ?)'
);
$repeatable->execute( $branch, 0 );
my %week_days_holidays;
while (my $row = $repeatable->fetchrow_hashref) {
while ( my $row = $repeatable->fetchrow_hashref ) {
my $key = $row->{weekday};
$week_days_holidays{$key}{title} = $row->{title};
$week_days_holidays{$key}{description} = $row->{description};
}
$self->{'week_days_holidays'} = \%week_days_holidays;
$repeatable->execute($branch,1);
$repeatable->execute( $branch, 1 );
my %day_month_holidays;
while (my $row = $repeatable->fetchrow_hashref) {
while ( my $row = $repeatable->fetchrow_hashref ) {
my $key = $row->{month} . "/" . $row->{day};
$day_month_holidays{$key}{title} = $row->{title};
$day_month_holidays{$key}{description} = $row->{description};
$day_month_holidays{$key}{day} = sprintf("%02d", $row->{day});
$day_month_holidays{$key}{month} = sprintf("%02d", $row->{month});
$day_month_holidays{$key}{day} = sprintf( "%02d", $row->{day} );
$day_month_holidays{$key}{month} = sprintf( "%02d", $row->{month} );
}
$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 = ?)' );
$special->execute($branch,1);
AND (isexception = ?)'
);
$special->execute( $branch, 1 );
my %exception_holidays;
while (my ($day, $month, $year, $title, $description) = $special->fetchrow) {
while ( my ( $day, $month, $year, $title, $description ) = $special->fetchrow ) {
$exception_holidays{"$year/$month/$day"}{title} = $title;
$exception_holidays{"$year/$month/$day"}{description} = $description;
$exception_holidays{"$year/$month/$day"}{date} =
sprintf(ISO_DATE_FORMAT, $year, $month, $day);
sprintf( ISO_DATE_FORMAT, $year, $month, $day );
}
$self->{'exception_holidays'} = \%exception_holidays;
$special->execute($branch,0);
$special->execute( $branch, 0 );
my %single_holidays;
while (my ($day, $month, $year, $title, $description) = $special->fetchrow) {
while ( my ( $day, $month, $year, $title, $description ) = $special->fetchrow ) {
$single_holidays{"$year/$month/$day"}{title} = $title;
$single_holidays{"$year/$month/$day"}{description} = $description;
$single_holidays{"$year/$month/$day"}{date} =
sprintf(ISO_DATE_FORMAT, $year, $month, $day);
sprintf( ISO_DATE_FORMAT, $year, $month, $day );
}
$self->{'single_holidays'} = \%single_holidays;
return $self;
@ -201,8 +207,10 @@ 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,?,? )");
$insertHoliday->execute( $self->{branchcode}, $weekday, $options{title}, $options{description});
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};
return $self;
@ -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,10 +370,11 @@ sub ModWeekdayholiday {
my %options = @_;
my $dbh = C4::Context->dbh();
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};
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};
return $self;
}
@ -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;
@ -414,10 +442,13 @@ sub ModSingleholiday {
my $dbh = C4::Context->dbh();
my $isexception = 0;
my $updateHoliday = $dbh->prepare("
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);
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
);
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
@ -457,12 +488,16 @@ sub ModExceptionholiday {
my $dbh = C4::Context->dbh();
my $isexception = 1;
my $updateHoliday = $dbh->prepare("
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);
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
);
$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,46 +536,52 @@ 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 = ?)");
$isSingleHoliday->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});
if ($isSingleHoliday->rows) {
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;
$isSingleHoliday->finish; # Close the last query
my $deleteHoliday = $dbh->prepare("DELETE FROM special_holidays WHERE id = ?");
$deleteHoliday->execute($id);
delete($self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"});
delete( $self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"} );
} else {
$isSingleHoliday->finish; # Close the last query
my $isWeekdayHoliday = $dbh->prepare("SELECT id FROM repeatable_holidays WHERE branchcode = ? AND weekday = ?");
$isWeekdayHoliday->execute($self->{branchcode}, $options{weekday});
if ($isWeekdayHoliday->rows) {
$isWeekdayHoliday->execute( $self->{branchcode}, $options{weekday} );
if ( $isWeekdayHoliday->rows ) {
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 = ?)");
$updateExceptions->execute($options{weekday}, $self->{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
my $deleteHoliday = $dbh->prepare("DELETE FROM repeatable_holidays WHERE id = ?");
$deleteHoliday->execute($id);
delete($self->{'week_days_holidays'}->{$options{weekday}});
delete( $self->{'week_days_holidays'}->{ $options{weekday} } );
} else {
$isWeekdayHoliday->finish; # Close the last query
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 $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 = ?)");
$updateExceptions->execute($self->{branchcode}, $options{day}, $options{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
my $deleteHoliday = $dbh->prepare("DELETE FROM repeatable_holidays WHERE (id = ?)");
$deleteHoliday->execute($id);
delete($self->{'day_month_holidays'}->{"$options{month}/$options{day}"});
delete( $self->{'day_month_holidays'}->{"$options{month}/$options{day}"} );
}
}
}
@ -552,6 +593,7 @@ sub delete_holiday {
return $self;
}
=head2 delete_holiday_range
delete_holiday_range(day => $day,
@ -573,8 +615,9 @@ 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 = ?)");
$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{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
my $cache = Koha::Caches->get_instance();
@ -602,7 +645,7 @@ sub delete_holiday_range_repeatable {
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare("DELETE FROM repeatable_holidays WHERE (branchcode = ?) AND (day = ?) AND (month = ?)");
$sth->execute($self->{branchcode}, $options{day}, $options{month});
$sth->execute( $self->{branchcode}, $options{day}, $options{month} );
# changed the 'single_holidays' table, lets force/reset its cache
my $cache = Koha::Caches->get_instance();
@ -632,8 +675,10 @@ 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 = ?)");
$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{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
my $cache = Koha::Caches->get_instance();
@ -654,22 +699,25 @@ C<$year> Is the year to check whether if is a holiday or not.
=cut
sub isHoliday {
my ($self, $day, $month, $year) = @_;
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;
$day=$day+0;
my $weekday = &Date::Calc::Day_of_Week($year, $month, $day) % 7;
$month = $month + 0;
$year = $year + 0;
$day = $day + 0;
my $weekday = &Date::Calc::Day_of_Week( $year, $month, $day ) % 7;
my $weekDays = $self->get_week_days_holidays();
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"})) {
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;
@ -685,44 +733,44 @@ sub isHoliday {
=cut
sub copy_to_branch {
my ($self, $target_branch) = @_;
my ( $self, $target_branch ) = @_;
croak "No target_branch" unless $target_branch;
my $target_calendar = C4::Calendar->new(branchcode => $target_branch);
my $target_calendar = C4::Calendar->new( branchcode => $target_branch );
my ($y, $m, $d) = Today();
my $today = sprintf ISO_DATE_FORMAT, $y,$m,$d;
my ( $y, $m, $d ) = Today();
my $today = sprintf ISO_DATE_FORMAT, $y, $m, $d;
my $wdh = $self->get_week_days_holidays;
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} } )
foreach my $key ( keys %$wdh ) {
unless ( grep { $_ eq $key } keys %$target_wdh ) {
$target_calendar->insert_week_day_holiday( weekday => $key, %{ $wdh->{$key} } );
}
}
my $dmh = $self->get_day_month_holidays;
my $target_dmh = $target_calendar->get_day_month_holidays;
foreach my $values (values %$dmh) {
unless (grep { $_->{day} eq $values->{day} && $_->{month} eq $values->{month} } values %$target_dmh) {
$target_calendar->insert_day_month_holiday(%{ $values });
foreach my $values ( values %$dmh ) {
unless ( grep { $_->{day} eq $values->{day} && $_->{month} eq $values->{month} } values %$target_dmh ) {
$target_calendar->insert_day_month_holiday( %{$values} );
}
}
my $exception_holidays = $self->get_exception_holidays;
my $target_exceptions = $target_calendar->get_exception_holidays;
foreach my $values ( grep {$_->{date} gt $today} values %{ $exception_holidays }) {
unless ( grep { $_->{date} eq $values->{date} } values %$target_exceptions) {
$target_calendar->insert_exception_holiday(%{ $values });
foreach my $values ( grep { $_->{date} gt $today } values %{$exception_holidays} ) {
unless ( grep { $_->{date} eq $values->{date} } values %$target_exceptions ) {
$target_calendar->insert_exception_holiday( %{$values} );
}
}
my $single_holidays = $self->get_single_holidays;
my $target_singles = $target_calendar->get_single_holidays;
foreach my $values ( grep {$_->{date} gt $today} values %{ $single_holidays }) {
unless ( grep { $_->{date} eq $values->{date} } values %$target_singles){
$target_calendar->insert_single_holiday(%{ $values });
foreach my $values ( grep { $_->{date} gt $today } values %{$single_holidays} ) {
unless ( grep { $_->{date} eq $values->{date} } values %$target_singles ) {
$target_calendar->insert_single_holiday( %{$values} );
}
}

1045
C4/Charset.pm
View File

File diff suppressed because it is too large Load Diff

1215
C4/Circulation.pm
View File

File diff suppressed because it is too large Load Diff

18
C4/ClassSortRoutine.pm
View File

@ -21,7 +21,8 @@ use Modern::Perl;
use Class::Factory::Util;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -48,10 +49,10 @@ use C4::ClassSortRoutine;
my %loaded_routines = ();
my @sort_routines = GetSortRoutineNames();
foreach my $sort_routine (@sort_routines) {
if (eval "require C4::ClassSortRoutine::$sort_routine") {
if ( eval "require C4::ClassSortRoutine::$sort_routine" ) {
my $ref;
$ref = \&{"C4::ClassSortRoutine::${sort_routine}::get_class_sort_key"};
if (eval { $ref->("a", "b") }) {
if ( eval { $ref->( "a", "b" ) } ) {
$loaded_routines{$sort_routine} = $ref;
} else {
$loaded_routines{$sort_routine} = \&_get_class_sort_key;
@ -87,17 +88,18 @@ normalization routine.
=cut
sub GetClassSortKey {
my ($sort_routine, $cn_class, $cn_item) = @_;
unless (exists $loaded_routines{$sort_routine}) {
my ( $sort_routine, $cn_class, $cn_item ) = @_;
unless ( exists $loaded_routines{$sort_routine} ) {
warn "attempting to use non-existent class sorting routine $sort_routine\n";
$loaded_routines{$sort_routine} = \&_get_class_sort_key;
}
my $key = $loaded_routines{$sort_routine}->($cn_class, $cn_item);
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
# independent of the DBMS, deferring for the moment.
return substr($key, 0, 255);
return substr( $key, 0, 255 );
}
=head2 _get_class_sort_key
@ -110,7 +112,7 @@ letter characters.
=cut
sub _get_class_sort_key {
my ($cn_class, $cn_item) = @_;
my ( $cn_class, $cn_item ) = @_;
my $key = uc "$cn_class $cn_item";
$key =~ s/\s+/_/;
$key =~ s/[^A-Z_0-9]//g;

26
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
@ -53,7 +51,7 @@ Generates sorting key using the following rules:
=cut
sub get_class_sort_key {
my ($cn_class, $cn_item) = @_;
my ( $cn_class, $cn_item ) = @_;
$cn_class = '' unless defined $cn_class;
$cn_item = '' unless defined $cn_item;
@ -66,27 +64,29 @@ 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+$/) {
for ( my $i = 0 ; $i <= $#tokens ; $i++ ) {
if ( $tokens[$i] =~ /^\d+$/ ) {
$digit_group_count++;
if (1 == $digit_group_count) {
if ( 1 == $digit_group_count ) {
$first_digit_group_idx = $i;
}
if (2 == $digit_group_count) {
if ($i - $first_digit_group_idx == 1) {
$tokens[$i] = sprintf("%-15.15s", $tokens[$i]);
if ( 2 == $digit_group_count ) {
if ( $i - $first_digit_group_idx == 1 ) {
$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'
if ( 1 == $digit_group_count ) {
$tokens[$first_digit_group_idx] .= '_000000000000000';
}
my $key = join("_", @tokens);
my $key = join( "_", @tokens );
$key =~ s/[^\p{IsAlnum}_]//g;
return $key;

4
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
@ -48,7 +46,7 @@ Generates sorting key using the following rules:
=cut
sub get_class_sort_key {
my ($cn_class, $cn_item) = @_;
my ( $cn_class, $cn_item ) = @_;
$cn_class = '' unless defined $cn_class;
$cn_item = '' unless defined $cn_item;

6
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
@ -45,11 +43,11 @@ Generates sorting key for LC call numbers.
=cut
sub get_class_sort_key {
my ($cn_class, $cn_item) = @_;
my ( $cn_class, $cn_item ) = @_;
$cn_class = '' unless defined $cn_class;
$cn_item = '' unless defined $cn_item;
my $call_number = Library::CallNumber::LC->new(uc "$cn_class $cn_item");
my $call_number = Library::CallNumber::LC->new( uc "$cn_class $cn_item" );
return '' unless defined $call_number;
my $key = $call_number->normalize();
$key = '' unless defined $key;

27
C4/ClassSource.pm
View File

@ -23,7 +23,8 @@ use C4::ClassSortRoutine qw( GetClassSortKey );
use Koha::Cache::Memory::Lite;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -79,12 +80,12 @@ 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" );;
unless( $class_sources ){
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`");
$sth->execute();
while (my $source = $sth->fetchrow_hashref) {
while ( my $source = $sth->fetchrow_hashref ) {
$class_sources->{ $source->{'cn_source'} } = $source;
}
$memory_cache->set_in_cache( "GetClassSource:All", $class_sources );
@ -107,7 +108,7 @@ sub GetClassSource {
return unless $cn_source;
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
my $class_source = $memory_cache->get_from_cache( "GetClassSource:" . $cn_source );
unless( $class_source ){
unless ($class_source) {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM `class_sources` WHERE cn_source = ?");
$sth->execute($cn_source);
@ -131,7 +132,7 @@ sub GetClassSortRule {
return unless $class_sort_rule;
my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
my $class_sort_rules = $memory_cache->get_from_cache( "GetClassSortRule:" . $class_sort_rule );
unless( $class_sort_rules ){
unless ($class_sort_rules) {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM `class_sort_rules` WHERE `class_sort_rule` = ?");
$sth->execute($class_sort_rule);
@ -152,21 +153,21 @@ and the defined call number source.
sub GetClassSort {
my ($cn_source, $cn_class, $cn_item) = @_;
my ( $cn_source, $cn_class, $cn_item ) = @_;
my $source_ref = GetClassSource($cn_source);
unless (defined $source_ref) {
$source_ref = GetClassSource(C4::Context->preference("DefaultClassificationSource"));
unless ( defined $source_ref ) {
$source_ref = GetClassSource( C4::Context->preference("DefaultClassificationSource") );
}
my $routine = "";
if (defined $source_ref) {
my $rule_ref = GetClassSortRule($source_ref->{'class_sort_rule'});
if (defined $rule_ref) {
if ( defined $source_ref ) {
my $rule_ref = GetClassSortRule( $source_ref->{'class_sort_rule'} );
if ( defined $rule_ref ) {
$routine = $rule_ref->{'sort_routine'};
}
}
return GetClassSortKey($routine, $cn_class, $cn_item);
return GetClassSortKey( $routine, $cn_class, $cn_item );
}

3
C4/ClassSplitRoutine.pm
View File

@ -21,7 +21,8 @@ use Modern::Perl;
use Class::Factory::Util;
our (@ISA, @EXPORT_OK);
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

8
C4/ClassSplitRoutine/LCC.pm
View File

@ -42,14 +42,16 @@ 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]) {
Koha::Logger->get->debug(sprintf('regexp failed to match string: %s', $cn_item));
unless ( scalar @lines && defined $lines[0] ) {
Koha::Logger->get->debug( sprintf( 'regexp failed to match string: %s', $cn_item ) );
@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;
}

4
C4/ClassSplitRoutine/RegEx.pm
View File

@ -38,9 +38,9 @@ my $cn_sort = C4::ClassSplitRoutine::RegEx::split_callnumber($cn_item, $regexs);
=cut
sub split_callnumber {
my ($cn_item, $regexs) = @_;
my ( $cn_item, $regexs ) = @_;
for my $regex ( @$regexs ) {
for my $regex (@$regexs) {
eval "\$cn_item =~ $regex"; ## no critic (StringyEval)
}
my @lines = split "\n", $cn_item;

156
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)
@ -111,7 +113,7 @@ sub import {
return if $context;
# no ? so load it!
my ($pkg,$config_file) = @_ ;
my ( $pkg, $config_file ) = @_;
my $new_ctx = __PACKAGE__->new($config_file);
return unless $new_ctx;
@ -146,12 +148,13 @@ 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;
unless ( $conf_fname ) {
unless ($conf_fname) {
warn "unable to locate Koha configuration file koha-conf.xml";
return;
}
@ -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;
}
@ -220,18 +223,19 @@ from which the current context was created.
=cut
sub _common_config {
my ($var, $term) = @_;
my ( $var, $term ) = @_;
return unless defined $context and defined $context->{config};
return $context->{config}->get($var, $term);
return $context->{config}->get( $var, $term );
}
sub config {
return _common_config($_[1],'config');
return _common_config( $_[1], 'config' );
}
sub zebraconfig {
return _common_config($_[1],'server');
return _common_config( $_[1], 'server' );
}
=head2 preference
@ -251,11 +255,12 @@ with this method.
=cut
my $use_syspref_cache = 1;
sub preference {
my $self = shift;
my $var = shift; # The system preference to return
return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"})
return Encode::decode_utf8( $ENV{"OVERRIDE_SYSPREF_$var"} )
if defined $ENV{"OVERRIDE_SYSPREF_$var"};
$var = lc $var;
@ -270,9 +275,9 @@ sub preference {
eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
my $value = $syspref ? $syspref->value() : undef;
if ( $use_syspref_cache ) {
if ($use_syspref_cache) {
my $syspref_cache = Koha::Caches->get_instance('syspref');
$syspref_cache->set_in_cache("syspref_$var", $value);
$syspref_cache->set_in_cache( "syspref_$var", $value );
}
return $value;
}
@ -288,14 +293,17 @@ the value cannot be properly decoded as YAML.
sub yaml_preference {
my ( $self, $preference ) = @_;
my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) // '' ) ); };
my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference($preference) // '' ) ); };
if ($@) {
warn "Unable to parse $preference syspref : $@";
return;
}
# 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,
@ -411,7 +422,7 @@ sub set_preference {
)->store();
}
if ( $use_syspref_cache ) {
if ($use_syspref_cache) {
my $syspref_cache = Koha::Caches->get_instance('syspref');
$syspref_cache->set_in_cache( "syspref_$variable", $value );
}
@ -433,8 +444,8 @@ sub delete_preference {
my ( $self, $var ) = @_;
$var = lc $var;
if ( Koha::Config::SysPrefs->find( $var )->delete ) {
if ( $use_syspref_cache ) {
if ( Koha::Config::SysPrefs->find($var)->delete ) {
if ($use_syspref_cache) {
my $syspref_cache = Koha::Caches->get_instance('syspref');
$syspref_cache->clear_from_cache("syspref_$var");
}
@ -511,13 +522,17 @@ C<$async> whether this is a asynchronous connection
=cut
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()) ) {
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 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};
}
@ -539,7 +554,7 @@ C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
sub _new_Zconn {
my ( $server, $async ) = @_;
my $tried=0; # first attempt
my $tried = 0; # first attempt
my $Zconn; # connection object
my $elementSetName;
my $syntax;
@ -549,33 +564,33 @@ sub _new_Zconn {
$syntax = 'xml';
$elementSetName = 'marcxml';
my $host = _common_config($server, 'listen')->{content};
my $serverinfo = _common_config($server, 'serverinfo');
my $host = _common_config( $server, 'listen' )->{content};
my $serverinfo = _common_config( $server, 'serverinfo' );
my $user = $serverinfo->{user};
my $password = $serverinfo->{password};
eval {
# set options
my $o = ZOOM::Options->new();
$o->option(user => $user) if $user && $password;
$o->option(password => $password) if $user && $password;
$o->option(async => 1) if $async;
$o->option(cqlfile=> _common_config($server, 'server')->{cql2rpn});
$o->option(cclfile=> $serverinfo->{ccl2rpn});
$o->option(preferredRecordSyntax => $syntax);
$o->option(elementSetName => $elementSetName) if $elementSetName;
$o->option(databaseName => _common_config($server, 'config') || 'biblios');
$o->option( user => $user ) if $user && $password;
$o->option( password => $password ) if $user && $password;
$o->option( async => 1 ) if $async;
$o->option( cqlfile => _common_config( $server, 'server' )->{cql2rpn} );
$o->option( cclfile => $serverinfo->{ccl2rpn} );
$o->option( preferredRecordSyntax => $syntax );
$o->option( elementSetName => $elementSetName ) if $elementSetName;
$o->option( databaseName => _common_config( $server, 'config' ) || 'biblios' );
my $timeout = C4::Context->config('zebra_connection_timeout') || 30;
$o->option(timeout => $timeout);
$o->option( timeout => $timeout );
# create a new connection object
$Zconn= create ZOOM::Connection($o);
$Zconn = create ZOOM::Connection($o);
# forge to server
$Zconn->connect($host, 0);
$Zconn->connect( $host, 0 );
# check for errors and warn
if ($Zconn->errcode() !=0) {
warn "something wrong with the connection: ". $Zconn->errmsg();
if ( $Zconn->errcode() != 0 ) {
warn "something wrong with the connection: " . $Zconn->errmsg();
}
};
return $Zconn;
@ -585,10 +600,9 @@ 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;
Koha::Database->schema( { new => 1 } )->storage->dbh;
}
=head2 dbh
@ -601,8 +615,7 @@ creates one, and connects to the database.
=cut
sub dbh
{
sub dbh {
my $self = shift;
my $params = shift;
@ -610,7 +623,7 @@ sub dbh
return Koha::Database->schema->storage->dbh;
}
return Koha::Database->schema({ new => 1 })->storage->dbh;
return Koha::Database->schema( { new => 1 } )->storage->dbh;
}
=head2 new_dbh
@ -627,11 +640,10 @@ 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 });
return &dbh( { new => 1 } );
}
=head2 userenv
@ -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
@ -722,7 +732,7 @@ sub get_versions {
my ( %versions, $mysqlVersion );
$versions{kohaVersion} = Koha::version();
$versions{kohaDbVersion} = C4::Context->preference('version');
$versions{osVersion} = join(" ", POSIX::uname());
$versions{osVersion} = join( " ", POSIX::uname() );
$versions{perlVersion} = $];
my $dbh = C4::Context->dbh;
@ -732,10 +742,10 @@ sub get_versions {
no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
$mysqlVersion ||= `mysql -V`; # fallback to sql client version?
$versions{apacheVersion} = (`apache2ctl -v`)[0];
$versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
$versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
$versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
$versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
$versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion};
$versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion};
$versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion};
$versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion};
}
$versions{mysqlVersion} = $mysqlVersion;
return %versions;
@ -751,14 +761,13 @@ sub get_versions {
sub tz {
my $self = shift;
if (!defined $context->{tz}) {
if ( !defined $context->{tz} ) {
my $timezone = $context->{config}->timezone;
$context->{tz} = DateTime::TimeZone->new(name => $timezone);
$context->{tz} = DateTime::TimeZone->new( name => $timezone );
}
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.
@ -776,7 +786,7 @@ sub IsSuperLibrarian {
return 1;
}
return ($userenv->{flags}//0) % 2;
return ( $userenv->{flags} // 0 ) % 2;
}
=head2 interface
@ -790,9 +800,9 @@ Sets the current interface for later retrieval in any Perl module
=cut
sub interface {
my ($class, $interface) = @_;
my ( $class, $interface ) = @_;
if (defined $interface) {
if ( defined $interface ) {
$interface = lc $interface;
if ( $interface eq 'api'
|| $interface eq 'opac'
@ -840,7 +850,7 @@ Returns root directory for temporary storage
=cut
sub temporary_directory {
my ( $class ) = @_;
my ($class) = @_;
return C4::Context->config('tmp_path') || File::Spec->tmpdir;
}
@ -882,8 +892,8 @@ We are relying on the convention of the value being "on" or "ON" here.
sub https_enabled {
my $https_enabled = 0;
my $env_https = $ENV{HTTPS};
if ($env_https){
if ($env_https =~ /^ON$/i){
if ($env_https) {
if ( $env_https =~ /^ON$/i ) {
$https_enabled = 1;
}
}
@ -902,7 +912,7 @@ This method returns a boolean representing the install status of the Koha instan
sub needs_install {
my ($self) = @_;
return ($self->preference('Version')) ? 0 : 1;
return ( $self->preference('Version') ) ? 0 : 1;
}
=head3 psgi_env
@ -914,7 +924,7 @@ this is a PSGI app or a CGI app, and implementing code as appropriate.
=cut
sub psgi_env {
my ( $self ) = @_;
my ($self) = @_;
return any { /^(psgi\.|plack\.|PLACK_ENV$)/i } keys %ENV;
}
@ -928,9 +938,9 @@ app
#NOTE: This is not a very robust method but it's the best we have so far
sub is_internal_PSGI_request {
my ( $self ) = @_;
my ($self) = @_;
my $is_internal = 0;
if( $self->psgi_env && ( $ENV{REQUEST_URI} !~ /^(\/intranet|\/opac)/ ) ) {
if ( $self->psgi_env && ( $ENV{REQUEST_URI} !~ /^(\/intranet|\/opac)/ ) ) {
$is_internal = 1;
}
return $is_internal;

19
C4/Contract.pm
View File

@ -51,7 +51,6 @@ a contract.
=cut
=head2 GetContracts
$contractlist = GetContracts({
@ -75,8 +74,8 @@ Returns a list of contracts
sub GetContracts {
my ($filters) = @_;
if( $filters->{activeonly} ) {
$filters->{contractenddate} = {'>=' => \'now()'};
if ( $filters->{activeonly} ) {
$filters->{contractenddate} = { '>=' => \'now()' };
delete $filters->{activeonly};
}
@ -102,15 +101,17 @@ sub GetContract {
return unless $contractnumber;
my $contracts = GetContracts({
my $contracts = GetContracts(
{
contractnumber => $contractnumber,
});
}
);
return $contracts->[0];
}
sub AddContract {
my ($contract) = @_;
return unless($contract->{booksellerid});
return unless ( $contract->{booksellerid} );
my $rs = Koha::Database->new()->schema->resultset('Aqcontract');
return $rs->create($contract)->id;
@ -119,7 +120,7 @@ sub AddContract {
sub ModContract {
my ($contract) = @_;
my $result = Koha::Database->new()->schema->resultset('Aqcontract')->find($contract);
return unless($result);
return unless ($result);
$result = $result->update($contract);
return $result->in_storage;
@ -127,10 +128,10 @@ sub ModContract {
sub DelContract {
my ($contract) = @_;
return unless($contract->{contractnumber});
return unless ( $contract->{contractnumber} );
my $result = Koha::Database->new()->schema->resultset('Aqcontract')->find($contract);
return unless($result);
return unless ($result);
eval { $result->delete };
return !( $result->in_storage );

88
C4/CourseReserves.pm
View File

@ -28,7 +28,8 @@ use Koha::Course::Reserves;
use Koha::Checkouts;
use vars qw(@FIELDS);
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -80,7 +81,7 @@ This module deals with course reserves.
sub GetCourse {
my ($course_id) = @_;
my $course = Koha::Courses->find( $course_id );
my $course = Koha::Courses->find($course_id);
return unless $course;
$course = $course->unblessed;
@ -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'},
);
@ -287,11 +292,14 @@ sub EnableOrDisableCourseItem {
my $ci_id = $params{'ci_id'};
return unless ( $ci_id );
return unless ($ci_id);
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';
@ -300,7 +308,7 @@ sub EnableOrDisableCourseItem {
## or disable and already disabled item,
## as that would cause the fields to swap
if ( $course_item->{'enabled'} ne $enabled ) {
_SwapAllFields($ci_id, $enabled );
_SwapAllFields( $ci_id, $enabled );
my $query = "
UPDATE course_items
@ -422,10 +430,10 @@ sub GetCourseItem {
return unless ( $itemnumber xor $biblionumber xor $ci_id );
my ( $field, $value );
if ( $itemnumber ) {
if ($itemnumber) {
$field = 'itemnumber';
$value = $itemnumber;
} elsif ( $biblionumber ) {
} elsif ($biblionumber) {
$field = 'biblionumber';
$value = $biblionumber;
} else {
@ -466,12 +474,13 @@ sub ModCourseItem {
my $itemnumber = $params{'itemnumber'};
my $biblionumber = $params{'biblionumber'};
return unless ($itemnumber xor $biblionumber);
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;
$biblionumber = Koha::Items->find($itemnumber)->biblionumber;
$params{biblionumber} = $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 );
@ -550,7 +560,7 @@ sub _UpdateCourseItem {
if ( $course_item->is_enabled ) {
my $item_fields = {};
for my $field ( @FIELDS ) {
for my $field (@FIELDS) {
my $field_enabled = $field . '_enabled';
my $field_storage = $field . '_storage';
@ -560,19 +570,21 @@ 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) {
elsif ( $course_item->$field_enabled ) {
$item_fields->{$field} = $params{$field};
}
}
$item->set( $item_fields )->store
$item->set($item_fields)->store
if keys %$item_fields;
}
}
@ -596,7 +608,7 @@ sub _RevertFields {
return unless $ci_id;
my $course_item = Koha::Course::Items->find( $ci_id );
my $course_item = Koha::Course::Items->find($ci_id);
my $item_fields = {};
$item_fields->{itype} = $course_item->itype_storage if $course_item->itype_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);
@ -627,7 +637,7 @@ sub _RevertFields {
sub _SwapAllFields {
my ( $ci_id, $enabled ) = @_;
my $course_item = Koha::Course::Items->find( $ci_id );
my $course_item = Koha::Course::Items->find($ci_id);
my $item = Koha::Items->find( $course_item->itemnumber );
if ( $enabled eq 'yes' ) { # Copy item fields to course item storage, course item fields to item
@ -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);
@ -726,7 +732,7 @@ sub DelCourseItem {
return unless ($ci_id);
my $course_item = Koha::Course::Items->find( $ci_id );
my $course_item = Koha::Course::Items->find($ci_id);
return unless $course_item;
_RevertFields( ci_id => $ci_id ) if $course_item->enabled eq 'yes';
@ -866,14 +872,17 @@ 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 $item = Koha::Items->find( $cr->{itemnumber}, { prefetch => [ 'biblio', '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;
$cr->{'biblio'} = $biblio;
$cr->{'biblioitem'} = $biblioitem;
$cr->{'issue'} = Koha::Checkouts->find({ itemnumber => $cr->{'itemnumber'} });
$cr->{'issue'} = Koha::Checkouts->find( { itemnumber => $cr->{'itemnumber'} } );
}
}
@ -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} );
}
}
@ -939,9 +951,10 @@ sub GetItemCourseReservesInfo {
my $itemnumber = $params{'itemnumber'};
my $biblionumber = $params{'biblionumber'};
return unless ($itemnumber xor $biblionumber);
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);

2
C4/Creators.pm
View File

@ -54,7 +54,7 @@ BEGIN {
get_text_justification_types
get_unit_values
html_table
);
);
use C4::Creators::PDF;
}

116
C4/Creators/Batch.pm
View File

@ -19,18 +19,17 @@ sub _check_params {
'branch_code',
'creator',
);
if (scalar(@_) >1) {
if ( scalar(@_) > 1 ) {
$given_params = {@_};
foreach my $key (keys %{$given_params}) {
if (!(grep m/$key/, @valid_template_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $key);
foreach my $key ( keys %{$given_params} ) {
if ( !( grep m/$key/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $key );
$exit_code = 1;
}
}
}
else {
if (!(grep m/$_/, @valid_template_params)) {
warn sprintf('Unrecognized parameter type of %s', $_);
} else {
if ( !( grep m/$_/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of %s', $_ );
$exit_code = 1;
}
}
@ -48,7 +47,7 @@ sub new {
batch_stat => 0, # False if any data has changed and the db has not been updated
@_,
};
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -56,33 +55,35 @@ sub add_item {
my $self = shift;
my $number = shift;
ref($self) =~ m/C4::(.+)::.+$/;
my $number_type = ($1 eq 'Patroncards' ? 'borrower_number' : 'item_number');
if ($self->{'batch_id'} == 0){ #if this is a new batch batch_id must be created
my $number_type = ( $1 eq 'Patroncards' ? 'borrower_number' : 'item_number' );
if ( $self->{'batch_id'} == 0 ) { #if this is a new batch batch_id must be created
my $sth = C4::Context->dbh->prepare("SELECT MAX(batch_id) FROM creator_batches;");
$sth->execute();
my $batch_id = $sth->fetchrow_array;
$self->{'batch_id'}= ++$batch_id;
$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) {
warn sprintf('Database returned the following error on attempted INSERT: %s', $sth->errstr);
# $sth->{'TraceLevel'} = 3;
$sth->execute( $self->{'batch_id'}, $self->{'description'}, $number, $self->{'branch_code'}, $1 );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted INSERT: %s', $sth->errstr );
return -1;
}
$query = "SELECT max(label_id) FROM creator_batches WHERE batch_id=? AND $number_type=? AND branch_code=?;";
my $sth1 = C4::Context->dbh->prepare($query);
$sth1->execute($self->{'batch_id'}, $number, $self->{'branch_code'});
$sth1->execute( $self->{'batch_id'}, $number, $self->{'branch_code'} );
my $label_id = $sth1->fetchrow_array;
push (@{$self->{'items'}}, {$number_type => $number, label_id => $label_id});
push( @{ $self->{'items'} }, { $number_type => $number, label_id => $label_id } );
$self->{'batch_stat'} = 1;
return 0;
}
sub get_attr {
my $self = shift;
return $self->{$_[0]};
return $self->{ $_[0] };
}
sub remove_item {
@ -90,13 +91,14 @@ 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) {
warn sprintf('Database returned the following error on attempted DELETE: %s', $sth->errstr);
# $sth->{'TraceLevel'} = 3;
$sth->execute( $label_id, $self->{'batch_id'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted DELETE: %s', $sth->errstr );
return -1;
}
@{$self->{'items'}} = grep{$_->{'label_id'} != $label_id} @{$self->{'items'}};
@{ $self->{'items'} } = grep { $_->{'label_id'} != $label_id } @{ $self->{'items'} };
$self->{'batch_stat'} = 1;
return 0;
}
@ -136,30 +138,31 @@ sub retrieve {
my %opts = @_;
my $type = ref($invocant) || $invocant;
$type =~ m/C4::(.+)::.+$/;
my $number_type = ($1 eq 'Patroncards' ? 'borrower_number' : 'item_number');
my $number_type = ( $1 eq 'Patroncards' ? 'borrower_number' : 'item_number' );
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'});
# $sth->{'TraceLevel'} = 3;
$sth->execute( $opts{'batch_id'} );
my $self = {
batch_id => $opts{'batch_id'},
items => [],
};
while (my $record = $sth->fetchrow_hashref) {
while ( my $record = $sth->fetchrow_hashref ) {
$self->{'branch_code'} = $record->{'branch_code'};
$self->{'creator'} = $record->{'creator'};
$self->{'description'} = $record->{'description'};
push (@{$self->{'items'}}, {$number_type => $record->{$number_type}, label_id => $record->{'label_id'}});
push( @{ $self->{'items'} }, { $number_type => $record->{$number_type}, label_id => $record->{'label_id'} } );
$record_flag = 1; # true if one or more rows were retrieved
}
return -2 if $record_flag == 0; # a hackish sort of way of indicating no such record exists
if ($sth->err) {
warn sprintf('Database returned the following error on attempted SELECT: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted SELECT: %s', $sth->errstr );
return -1;
}
$self->{'batch_stat'} = 1;
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -168,27 +171,27 @@ sub delete {
my %opts = ();
my $call_type = '';
my @query_params = ();
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
$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 {
@query_params = ( $self->{'batch_id'}, $self->{'branch_code'} );
} else {
shift @_;
%opts = @_;
$call_type = 'C4::Labels::Batch::delete';
@query_params = ($opts{'batch_id'}, $opts{'branch_code'});
@query_params = ( $opts{'batch_id'}, $opts{'branch_code'} );
}
if ($query_params[0] eq '') { # If there is no template id then we cannot delete it
warn sprintf('%s : Cannot delete batch as the batch ID is invalid or non-existent.', $call_type);
if ( $query_params[0] eq '' ) { # If there is no template id then we cannot delete it
warn sprintf( '%s : Cannot delete batch as the batch ID is invalid or non-existent.', $call_type );
return -1;
}
my $query = "DELETE FROM creator_batches WHERE batch_id = ? AND branch_code =?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
# $sth->{'TraceLevel'} = 3;
$sth->execute(@query_params);
if ($sth->err) {
warn sprintf('%s : Database returned the following error on attempted INSERT: %s', $call_type, $sth->errstr);
if ( $sth->err ) {
warn sprintf( '%s : Database returned the following error on attempted INSERT: %s', $call_type, $sth->errstr );
return -1;
}
return 0;
@ -196,22 +199,27 @@ sub delete {
sub remove_duplicates {
my $self = shift;
my %seen=();
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);
$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
);
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);
}

101
C4/Creators/Layout.pm
View File

@ -41,18 +41,17 @@ sub _check_params {
'units',
'start_label',
);
if (scalar(@_) >1) {
if ( scalar(@_) > 1 ) {
my %given_params = @_;
foreach my $key (keys %given_params) {
if (!(grep m/$key/, @valtmpl_id_params)) {
warn sprintf('(Multiple parameters) Unrecognized parameter type of "%s".', $key);
foreach my $key ( keys %given_params ) {
if ( !( grep m/$key/, @valtmpl_id_params ) ) {
warn sprintf( '(Multiple parameters) Unrecognized parameter type of "%s".', $key );
$exit_code = 1;
}
}
}
else {
if (!(grep m/$_/, @valtmpl_id_params)) {
warn sprintf('(Single parameter) Unrecognized parameter type of "%s".', $_);
} else {
if ( !( grep m/$_/, @valtmpl_id_params ) ) {
warn sprintf( '(Single parameter) Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
}
}
@ -60,10 +59,11 @@ sub _check_params {
}
use constant PRESET_FIELDS => [qw(title author isbn issn itemtype barcode itemcallnumber)];
sub new {
my $invocant = shift;
my $self = '';
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my $type = ref($invocant) || $invocant;
@ -86,14 +86,13 @@ 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);
bless( $self, $type );
return $self;
}
@ -103,13 +102,13 @@ sub retrieve {
my $type = ref($invocant) || $invocant;
my $query = "SELECT * FROM creator_layouts WHERE layout_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute($opts{'layout_id'}, $opts{'creator'});
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute( $opts{'layout_id'}, $opts{'creator'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
my $self = $sth->fetchrow_hashref;
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -118,72 +117,73 @@ sub delete {
my %opts = ();
my $call_type = '';
my @params = ();
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
$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];
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];
return -1;
}
my $query = "DELETE FROM creator_layouts WHERE layout_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error on attempted DELETE: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted DELETE: %s', $sth->errstr );
return -1;
}
}
sub save {
my $self = shift;
if ($self->{'layout_id'}) { # if we have an id, the record exists and needs UPDATE
if ( $self->{'layout_id'} ) { # if we have an id, the record exists and needs UPDATE
my @params;
my $query = "UPDATE creator_layouts SET ";
foreach my $key (keys %{$self}) {
next if ($key eq 'layout_id') || ($key eq 'creator');
push (@params, $self->{$key});
foreach my $key ( keys %{$self} ) {
next if ( $key eq 'layout_id' ) || ( $key eq 'creator' );
push( @params, $self->{$key} );
$query .= "$key=?, ";
}
$query = substr($query, 0, (length($query)-2));
$query = substr( $query, 0, ( length($query) - 2 ) );
$query .= " WHERE layout_id=? AND creator = ?;";
push (@params, $self->{'layout_id'}, $self->{'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) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
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 (";
foreach my $key (keys %{$self}) {
push (@params, $self->{$key});
foreach my $key ( keys %{$self} ) {
push( @params, $self->{$key} );
$query .= "$key, ";
}
$query = substr($query, 0, (length($query)-2));
$query = substr( $query, 0, ( length($query) - 2 ) );
$query .= ") VALUES (";
for (my $i=1; $i<=(scalar keys %$self); $i++) {
for ( my $i = 1 ; $i <= ( scalar keys %$self ) ; $i++ ) {
$query .= "?,";
}
$query = substr($query, 0, (length($query)-1));
$query = substr( $query, 0, ( length($query) - 1 ) );
$query .= ");";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
my $sth1 = C4::Context->dbh->prepare("SELECT MAX(layout_id) FROM creator_layouts;");
@ -196,14 +196,13 @@ sub save {
sub get_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my ($attr) = @_;
if (exists($self->{$attr})) {
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
return;
@ -211,13 +210,13 @@ sub get_attr {
sub set_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my %attrs = @_;
foreach my $attrib (keys(%attrs)) {
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
return 0;
}
@ -227,9 +226,9 @@ sub get_text_wrap_cols {
my $string = '';
my $strwidth = 0;
my $col_count = 0;
my $textlimit = $params{'label_width'} - (( 3 * $params{'left_text_margin'} ) || 13.5 );
my $textlimit = $params{'label_width'} - ( ( 3 * $params{'left_text_margin'} ) || 13.5 );
while ($strwidth < $textlimit) {
while ( $strwidth < $textlimit ) {
$string .= '8'; # using '8' as filling char instead of '0'
$col_count++;
$strwidth = C4::Creators::PDF->StrWidth( $string, $self->{'font'}, $self->{'font_size'} );

303
C4/Creators/Lib.pm
View File

@ -66,105 +66,143 @@ C4::Creators::Lib
sub _SELECT {
my @params = @_;
my $fieldname = _add_backtics($params[0]);
my $fieldname = _add_backtics( $params[0] );
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->{'TraceLevel'} = 3;
$sth->execute();
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
my $record_set = [];
while (my $row = $sth->fetchrow_hashref()) {
push(@$record_set, $row);
while ( my $row = $sth->fetchrow_hashref() ) {
push( @$record_set, $row );
}
return $record_set;
}
sub _add_backtics {
my ( @args ) = @_;
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 => '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 => '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},
# {type => 'UPCA', name => 'UPCA', desc => 'Translates a string of 11 or 12 digits to UPCA barcodes. The check number (the 12:th digit) is calculated if not supplied.', selected => 0},
# {type => 'UPCE', name => 'UPCE', desc => 'Translates a string of 6, 7 or 8 digits to UPCE barcodes. If the string is 6 digits long, '0' is added first in the string. The check number (the 8: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 => '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},
# {type => 'UPCA', name => 'UPCA', desc => 'Translates a string of 11 or 12 digits to UPCA barcodes. The check number (the 12:th digit) is calculated if not supplied.', selected => 0},
# {type => 'UPCE', name => 'UPCE', desc => 'Translates a string of 6, 7 or 8 digits to UPCE barcodes. If the string is 6 digits long, '0' is added first in the string. The check number (the 8:th digit) is calculated if not supplied.', selected => 0},
];
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 => 'BAR', name => 'Barcode', desc => 'Only the barcode is printed.', selected => 0},
{ 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 => 'BAR', name => 'Barcode', desc => 'Only the barcode is printed.', selected => 0 },
];
my $font_types = [
{type => 'TR', name => 'Times-Roman', selected => 0},
{type => 'TB', name => 'Times-Bold', selected => 0},
{type => 'TI', name => 'Times-Italic', selected => 0},
{type => 'TBI', name => 'Times-Bold-Italic', selected => 0},
{type => 'C', name => 'Courier', selected => 0},
{type => 'CB', name => 'Courier-Bold', selected => 0},
{type => 'CO', name => 'Courier-Oblique', selected => 0},
{type => 'CBO', name => 'Courier-Bold-Oblique', selected => 0},
{type => 'H', name => 'Helvetica', selected => 0},
{type => 'HO', name => 'Helvetica-Oblique', selected => 0},
{type => 'HB', name => 'Helvetica-Bold', selected => 0},
{type => 'HBO', name => 'Helvetica-Bold-Oblique', selected => 0},
{ type => 'TR', name => 'Times-Roman', selected => 0 },
{ type => 'TB', name => 'Times-Bold', selected => 0 },
{ type => 'TI', name => 'Times-Italic', selected => 0 },
{ type => 'TBI', name => 'Times-Bold-Italic', selected => 0 },
{ type => 'C', name => 'Courier', selected => 0 },
{ type => 'CB', name => 'Courier-Bold', selected => 0 },
{ type => 'CO', name => 'Courier-Oblique', selected => 0 },
{ type => 'CBO', name => 'Courier-Bold-Oblique', selected => 0 },
{ type => 'H', name => 'Helvetica', selected => 0 },
{ type => 'HO', name => 'Helvetica-Oblique', selected => 0 },
{ type => 'HB', name => 'Helvetica-Bold', selected => 0 },
{ type => 'HBO', name => 'Helvetica-Bold-Oblique', selected => 0 },
];
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},
{ type => 'L', name => 'Left', selected => 0 },
{ type => 'C', name => 'Center', selected => 0 },
{ type => 'R', name => 'Right', selected => 0 },
# {type => 'F', name => 'Full', selected => 0},
];
my $unit_values = [
{type => 'POINT', desc => 'PostScript Points', value => 1, selected => 0},
{type => 'AGATE', desc => 'Adobe Agates', value => 5.1428571, selected => 0},
{type => 'INCH', desc => 'US Inches', value => 72, selected => 0},
{type => 'MM', desc => 'SI Millimeters', value => 2.83464567, selected => 0},
{type => 'CM', desc => 'SI Centimeters', value => 28.3464567, selected => 0},
{ type => 'POINT', desc => 'PostScript Points', value => 1, selected => 0 },
{ type => 'AGATE', desc => 'Adobe Agates', value => 5.1428571, selected => 0 },
{ type => 'INCH', desc => 'US Inches', value => 72, selected => 0 },
{ type => 'MM', desc => 'SI Millimeters', value => 2.83464567, selected => 0 },
{ type => 'CM', desc => 'SI Centimeters', value => 28.3464567, selected => 0 },
];
my $output_formats = [
{type => 'pdf', desc => 'PDF File'},
{type => 'csv', desc => 'CSV File'},
{ type => 'pdf', desc => 'PDF File' },
{ type => 'csv', desc => 'CSV File' },
];
sub _build_query {
my ( $params, $table ) = @_;
my @fields = exists $params->{fields} ? _add_backtics( @{ $params->{fields} } ) : ('*');
my $query = "SELECT " . join(', ', @fields ) . " FROM $table";
my $query = "SELECT " . join( ', ', @fields ) . " FROM $table";
my @where_args;
if ( exists $params->{filters} ) {
$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...
if ( ref($values) ) {
$query .=
" AND `$field` IN ( "
. ( ('?,') x ( @$values - 1 ) )
. "? ) "; # a comma separates elements in a list...
push @where_args, @$values;
} else {
$query .= " AND `$field` = ? ";
@ -172,7 +210,7 @@ sub _build_query {
}
}
}
$query .= (exists $params->{orderby} ? " ORDER BY $params->{orderby} " : '');
$query .= ( exists $params->{orderby} ? " ORDER BY $params->{orderby} " : '' );
return ( $query, @where_args );
}
@ -185,18 +223,18 @@ This function returns a reference to a hash containing all templates upon succes
=cut
sub get_all_templates {
my ( $params ) = @_;
my ($params) = @_;
my @templates = ();
my ( $query, @where_args ) = _build_query( $params, 'creator_templates' );
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( @where_args );
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute(@where_args);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
ADD_TEMPLATES:
while (my $template = $sth->fetchrow_hashref) {
push(@templates, $template);
ADD_TEMPLATES:
while ( my $template = $sth->fetchrow_hashref ) {
push( @templates, $template );
}
return \@templates;
}
@ -210,18 +248,18 @@ This function returns a reference to a hash containing all layouts upon success
=cut
sub get_all_layouts {
my ( $params ) = @_;
my ($params) = @_;
my @layouts = ();
my ( $query, @where_args ) = _build_query( $params, 'creator_layouts' );
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( @where_args );
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute(@where_args);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
ADD_LAYOUTS:
while (my $layout = $sth->fetchrow_hashref) {
push(@layouts, $layout);
ADD_LAYOUTS:
while ( my $layout = $sth->fetchrow_hashref ) {
push( @layouts, $layout );
}
return \@layouts;
}
@ -241,18 +279,18 @@ NOTE: Do not pass in the keyword 'WHERE.'
=cut
sub get_all_profiles {
my ( $params ) = @_;
my ($params) = @_;
my @profiles = ();
my ( $query, @where_args ) = _build_query( $params, 'printers_profile' );
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( @where_args );
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute(@where_args);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
ADD_PROFILES:
while (my $profile = $sth->fetchrow_hashref) {
push(@profiles, $profile);
ADD_PROFILES:
while ( my $profile = $sth->fetchrow_hashref ) {
push( @profiles, $profile );
}
return \@profiles;
}
@ -266,11 +304,11 @@ sub get_all_image_names {
my $query = "SELECT image_name FROM creator_images";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute();
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
grep {push @$image_names, {type => $$_[0], name => $$_[0], selected => 0}} @{$sth->fetchall_arrayref([0])};
grep { push @$image_names, { type => $$_[0], name => $$_[0], selected => 0 } } @{ $sth->fetchall_arrayref( [0] ) };
return $image_names;
}
@ -289,19 +327,19 @@ NOTE: Do not pass in the keyword 'WHERE.'
=cut
sub get_batch_summary {
my ( $params ) = @_;
my ($params) = @_;
my @batches = ();
$params->{fields} = ['batch_id', 'description', 'count(batch_id) as _item_count'];
$params->{fields} = [ 'batch_id', 'description', 'count(batch_id) as _item_count' ];
my ( $query, @where_args ) = _build_query( $params, 'creator_batches' );
$query .= " GROUP BY batch_id, description";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute( @where_args );
if ($sth->err) {
warn sprintf('Database returned the following error on attempted SELECT: %s', $sth->errstr);
$sth->execute(@where_args);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted SELECT: %s', $sth->errstr );
return -1;
}
while (my $batch = $sth->fetchrow_hashref) {
push(@batches, $batch);
while ( my $batch = $sth->fetchrow_hashref ) {
push( @batches, $batch );
}
return \@batches;
}
@ -331,27 +369,30 @@ sub get_label_summary {
WHERE itemnumber=? AND batch_id=?;
";
my $sth = C4::Context->dbh->prepare($query);
foreach my $item (@{$params{'items'}}) {
foreach my $item ( @{ $params{'items'} } ) {
$label_number++;
$sth->execute($item->{'item_number'}, $params{'batch_id'});
if ($sth->err) {
warn sprintf('Database returned the following error on attempted SELECT: %s', $sth->errstr);
$sth->execute( $item->{'item_number'}, $params{'batch_id'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted SELECT: %s', $sth->errstr );
return -1;
}
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'};
$label_summary->{'_label_id'} = $item->{'label_id'};
push (@label_summaries, $label_summary);
push( @label_summaries, $label_summary );
}
return \@label_summaries;
}
@ -376,11 +417,11 @@ sub get_card_summary {
my @card_summaries = ();
my $query = "SELECT CONCAT_WS(', ', surname, firstname) AS name, cardnumber FROM borrowers WHERE borrowernumber=?;";
my $sth = C4::Context->dbh->prepare($query);
foreach my $item (@{$params{'items'}}) {
foreach my $item ( @{ $params{'items'} } ) {
$card_number++;
$sth->execute($item->{'borrower_number'});
if ($sth->err) {
warn sprintf('Database returned the following error on attempted SELECT: %s', $sth->errstr);
$sth->execute( $item->{'borrower_number'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted SELECT: %s', $sth->errstr );
return -1;
}
my $record = $sth->fetchrow_hashref;
@ -388,7 +429,7 @@ sub get_card_summary {
$card_summary->{'_summary'} = $record->{'name'};
$card_summary->{'borrowernumber'} = $item->{'borrower_number'};
$card_summary->{'_label_id'} = $item->{'label_id'};
push (@card_summaries, $card_summary);
push( @card_summaries, $card_summary );
}
return \@card_summaries;
}
@ -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.
@ -478,9 +518,9 @@ sub get_table_names {
my $search_term = shift;
my $dbh = C4::Context->dbh();
my $table_names = [];
my $sth = $dbh->table_info(undef,undef,"%$search_term%");
while (my $info = $sth->fetchrow_hashref()){
push (@$table_names, $info->{'TABLE_NAME'});
my $sth = $dbh->table_info( undef, undef, "%$search_term%" );
while ( my $info = $sth->fetchrow_hashref() ) {
push( @$table_names, $info->{'TABLE_NAME'} );
}
return $table_names;
}
@ -528,56 +568,71 @@ sub html_table {
my $table = [];
my $fields = [];
my @table_columns = ();
my ($row_index, $col_index) = (0,0);
my ( $row_index, $col_index ) = ( 0, 0 );
my $cols = 0; # number of columns to wrap on
my $field_count = 0;
my $select_value = undef;
my $link_field = undef;
POPULATE_HEADER:
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'}};
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'}
};
# do special formatting stuff....
$select_value = $header->{$key[0]}{'value'};
}
else {
$select_value = $header->{ $key[0] }{'value'};
} 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'}};
$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'}
};
}
$field_count++;
$col_index++;
}
$$table[0] = {header_fields => $fields};
$$table[0] = { header_fields => $fields };
$cols = $col_index;
$field_count *= scalar(@$data); # total fields to be displayed in the table
$col_index = 0;
$row_index++;
$fields = [];
POPULATE_TABLE:
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}};
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}
};
$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'
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}};
} 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}
};
$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};
$$table[$row_index] = { text_fields => $fields };
$col_index = 0;
$row_index++;
$fields = [];

61
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;
@ -67,18 +66,18 @@ sub new {
my $type = ref($invocant) || $invocant;
my %opts = @_;
my $self = {};
_InitVars() if ($opts{InitVars} == 0);
_InitVars($opts{InitVars}) if ($opts{InitVars} > 0);
delete($opts{InitVars});
prDocDir($opts{'DocDir'}) if $opts{'DocDir'};
delete($opts{'DocDir'});
_InitVars() if ( $opts{InitVars} == 0 );
_InitVars( $opts{InitVars} ) if ( $opts{InitVars} > 0 );
delete( $opts{InitVars} );
prDocDir( $opts{'DocDir'} ) if $opts{'DocDir'};
delete( $opts{'DocDir'} );
my $fh = File::Temp->new( UNLINK => 0, SUFFIX => '.pdf' );
$opts{Name} = $self->{filename} = "$fh"; # filename
close $fh; # we need just filename
prFile(\%opts);
bless ($self, $type);
prFile( \%opts );
bless( $self, $type );
return $self;
}
@ -89,7 +88,7 @@ sub End {
# slurp temporary filename and print it out for plack to pick up
local $/ = undef;
open(my $fh, '<', $self->{filename}) || die "$self->{filename}: $!";
open( my $fh, '<', $self->{filename} ) || die "$self->{filename}: $!";
print <$fh>;
close $fh;
unlink $self->{filename};
@ -127,14 +126,14 @@ sub DocForm {
sub Extract {
my $self = shift;
my ($pdfFile, $pageNo, $oldInternalName) = @_;
return prExtract($pdfFile, $pageNo, $oldInternalName);
my ( $pdfFile, $pageNo, $oldInternalName ) = @_;
return prExtract( $pdfFile, $pageNo, $oldInternalName );
}
sub Field {
my $self = shift;
my ($fieldName, $value) = @_;
prField($fieldName, $value);
my ( $fieldName, $value ) = @_;
prField( $fieldName, $value );
}
sub Font {
@ -143,10 +142,10 @@ sub Font {
my $ttf = C4::Context->config('ttf');
if ( $ttf ) {
if ($ttf) {
my $ttf_path = first { $_->{type} eq $fontName } @{ $ttf->{font} };
if ( -e $ttf_path->{content} ) {
return prTTFont($ttf_path->{content});
return prTTFont( $ttf_path->{content} );
} else {
warn "ERROR in koha-conf.xml -- missing <font type=\"$fontName\">/path/to/font.ttf</font>";
}
@ -185,20 +184,24 @@ sub Image {
sub Init {
my $self = shift;
my ($string, $duplicateCode) = @_;
prInit($string, $duplicateCode);
my ( $string, $duplicateCode ) = @_;
prInit( $string, $duplicateCode );
}
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 {
my $self = shift;
my ($imageData, $width, $height, $imageFormat) = @_;
return prJpeg($imageData, $width, $height, $imageFormat);
my ( $imageData, $width, $height, $imageFormat ) = @_;
return prJpeg( $imageData, $width, $height, $imageFormat );
}
sub Js {
@ -227,8 +230,8 @@ sub LogDir {
sub Mbox {
my $self = shift;
my ($lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY) = @_;
prMbox($lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY);
my ( $lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY ) = @_;
prMbox( $lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY );
}
sub Page {
@ -239,24 +242,24 @@ sub Page {
sub SinglePage {
my $self = shift;
my ($file, $pageNumber) = @_;
return prSinglePage($file, $pageNumber);
my ( $file, $pageNumber ) = @_;
return prSinglePage( $file, $pageNumber );
}
sub StrWidth {
my $self = shift;
my ($string, $font, $fontSize) = @_;
my ( $string, $font, $fontSize ) = @_;
# replace font code with correct internal font
$font = C4::Creators::PDF->Font($font);
return prStrWidth($string, $font, $fontSize);
return prStrWidth( $string, $font, $fontSize );
}
sub Text {
my $self = shift;
my ($x, $y, $string, $align, $rotation) = @_;
return prText($x, $y, $string, $align, $rotation);
my ( $x, $y, $string, $align, $rotation ) = @_;
return prText( $x, $y, $string, $align, $rotation );
}
sub TTFont {

105
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;
@ -23,18 +22,17 @@ sub _check_params {
'units',
'creator',
);
if (scalar(@_) >1) {
if ( scalar(@_) > 1 ) {
$given_params = {@_};
foreach my $key (keys %{$given_params}) {
if (!(grep m/$key/, @valid_profile_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $key);
foreach my $key ( keys %{$given_params} ) {
if ( !( grep m/$key/, @valid_profile_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $key );
$exit_code = 1;
}
}
}
else {
if (!(grep m/$_/, @valid_profile_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $_);
} else {
if ( !( grep m/$_/, @valid_profile_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
}
}
@ -43,7 +41,7 @@ sub _check_params {
sub _conv_points {
my $self = shift;
my @unit_value = grep {$_->{'type'} eq $self->{units}} @{get_unit_values()};
my @unit_value = grep { $_->{'type'} eq $self->{units} } @{ get_unit_values() };
$self->{offset_horz} = $self->{offset_horz} * $unit_value[0]->{'value'};
$self->{offset_vert} = $self->{offset_vert} * $unit_value[0]->{'value'};
$self->{creep_horz} = $self->{creep_horz} * $unit_value[0]->{'value'};
@ -53,7 +51,7 @@ sub _conv_points {
sub new {
my $invocant = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my $type = ref($invocant) || $invocant;
@ -68,7 +66,7 @@ sub new {
units => 'POINT',
@_,
};
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -78,14 +76,14 @@ sub retrieve {
my $type = ref($invocant) || $invocant;
my $query = "SELECT * FROM printers_profile WHERE profile_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute($opts{'profile_id'}, $opts{'creator'});
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute( $opts{'profile_id'}, $opts{'creator'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
my $self = $sth->fetchrow_hashref;
$self = _conv_points($self) if ($opts{convert} && $opts{convert} == 1);
bless ($self, $type);
$self = _conv_points($self) if ( $opts{convert} && $opts{convert} == 1 );
bless( $self, $type );
return $self;
}
@ -94,28 +92,30 @@ sub delete {
my %opts = ();
my $call_type = '';
my @params = ();
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
$self = shift; # check to see if this is a method call
$call_type = 'C4::'. $self->{'creator'} .'::Profile->delete';
$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];
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];
return -1;
}
my $query = "DELETE FROM printers_profile WHERE profile_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
# $sth->{'TraceLevel'} = 3;
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error on attempted DELETE: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted DELETE: %s', $sth->errstr );
return -1;
}
return 0;
@ -123,44 +123,44 @@ sub delete {
sub save {
my $self = shift;
if ($self->{'profile_id'}) { # if we have an profile_id, the record exists and needs UPDATE
if ( $self->{'profile_id'} ) { # if we have an profile_id, the record exists and needs UPDATE
my @params;
my $query = "UPDATE printers_profile SET ";
foreach my $key (keys %{$self}) {
next if ($key eq 'profile_id') || ($key eq 'creator');
push (@params, $self->{$key});
foreach my $key ( keys %{$self} ) {
next if ( $key eq 'profile_id' ) || ( $key eq 'creator' );
push( @params, $self->{$key} );
$query .= "$key=?, ";
}
$query = substr($query, 0, (length($query)-2));
push (@params, $self->{'profile_id'}, $self->{'creator'});
$query = substr( $query, 0, ( length($query) - 2 ) );
push( @params, $self->{'profile_id'}, $self->{'creator'} );
$query .= " WHERE profile_id=? AND creator=?;";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
# $sth->{'TraceLevel'} = 3;
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error on attempted UPDATE: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted UPDATE: %s', $sth->errstr );
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}) {
push (@params, $self->{$key});
foreach my $key ( keys %{$self} ) {
push( @params, $self->{$key} );
$query .= "$key, ";
}
$query = substr($query, 0, (length($query)-2));
$query = substr( $query, 0, ( length($query) - 2 ) );
$query .= ") VALUES (";
for (my $i=1; $i<=(scalar keys %$self); $i++) {
for ( my $i = 1 ; $i <= ( scalar keys %$self ) ; $i++ ) {
$query .= "?,";
}
$query = substr($query, 0, (length($query)-1));
$query = substr( $query, 0, ( length($query) - 1 ) );
$query .= ");";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error on attempted INSERT: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error on attempted INSERT: %s', $sth->errstr );
return -1;
}
my $sth1 = C4::Context->dbh->prepare("SELECT MAX(profile_id) FROM printers_profile;");
@ -172,28 +172,27 @@ sub save {
sub get_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my ($attr) = @_;
if (exists($self->{$attr})) {
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
warn sprintf('%s is currently undefined.', $attr);
} else {
warn sprintf( '%s is currently undefined.', $attr );
return -1;
}
}
sub set_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my %attrs = @_;
foreach my $attrib (keys(%attrs)) {
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
return 0;
}

156
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 = {};
@ -36,18 +35,17 @@ sub _check_params {
'creator',
'current_label',
);
if (scalar(@_) >1) {
if ( scalar(@_) > 1 ) {
$given_params = {@_};
foreach my $key (keys %{$given_params}) {
if (!(grep m/$key/, @valid_template_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $key);
foreach my $key ( keys %{$given_params} ) {
if ( !( grep m/$key/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $key );
$exit_code = 1;
}
}
}
else {
if (!(grep m/$_/, @valid_template_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $_);
} else {
if ( !( grep m/$_/, @valid_template_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $_ );
$exit_code = 1;
}
}
@ -56,7 +54,7 @@ sub _check_params {
sub _conv_points {
my $self = shift;
my @unit_value = grep {$_->{'type'} eq $self->{'units'}} @{get_unit_values()};
my @unit_value = grep { $_->{'type'} eq $self->{'units'} } @{ get_unit_values() };
$self->{'page_width'} = $self->{'page_width'} * $unit_value[0]->{'value'};
$self->{'page_height'} = $self->{'page_height'} * $unit_value[0]->{'value'};
$self->{'label_width'} = $self->{'label_width'} * $unit_value[0]->{'value'};
@ -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
@ -84,7 +83,7 @@ sub _apply_profile {
sub new {
my $invocant = shift;
my $type = ref($invocant) || $invocant;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my $self = {
@ -107,7 +106,7 @@ sub new {
template_stat => 0, # false if any data has changed and the db has not been updated
@_,
};
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -117,16 +116,17 @@ sub retrieve {
my $type = ref($invocant) || $invocant;
my $query = "SELECT * FROM " . $opts{'table_name'} . " WHERE template_id = ? AND creator = ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute($opts{'template_id'}, $opts{'creator'});
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute( $opts{'template_id'}, $opts{'creator'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
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 = _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->{'template_stat'} = 1;
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -135,19 +135,20 @@ sub delete {
my %opts = ();
my $call_type = '';
my @query_params = ();
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
$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];
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];
return -1;
}
my $query = "DELETE FROM creator_templates WHERE template_id = ? AND creator = ?";
@ -159,48 +160,47 @@ sub delete {
sub save {
my $self = shift;
my %opts = @_;
if ($self->{'template_id'}) { # if we have an template_id, the record exists and needs UPDATE
if ( $self->{'template_id'} ) { # if we have an template_id, the record exists and needs UPDATE
my @params;
my $query = "UPDATE " . $opts{'table_name'} . " SET ";
foreach my $key (keys %{$self}) {
next if ($key eq 'template_id') || ($key eq 'template_stat') || ($key eq 'creator');
push (@params, $self->{$key});
foreach my $key ( keys %{$self} ) {
next if ( $key eq 'template_id' ) || ( $key eq 'template_stat' ) || ( $key eq 'creator' );
push( @params, $self->{$key} );
$query .= "`$key`=?, ";
}
$query = substr($query, 0, (length($query)-2));
push (@params, $self->{'template_id'}, $self->{'creator'});
$query = substr( $query, 0, ( length($query) - 2 ) );
push( @params, $self->{'template_id'}, $self->{'creator'} );
$query .= " WHERE template_id=? AND creator=?;";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
$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}) {
my $query = "INSERT INTO " . $opts{'table_name'} . " (";
foreach my $key ( keys %{$self} ) {
next if $key eq 'template_stat';
push (@params, $self->{$key});
push( @params, $self->{$key} );
$query .= "`$key`, ";
}
$query = substr($query, 0, (length($query)-2));
$query = substr( $query, 0, ( length($query) - 2 ) );
$query .= ") VALUES (";
for (my $i=1; $i<=((scalar keys %$self) - 1); $i++) { # key count less keys not db related...
for ( my $i = 1 ; $i <= ( ( scalar keys %$self ) - 1 ) ; $i++ ) { # key count less keys not db related...
$query .= "?,";
}
$query = substr($query, 0, (length($query)-1));
$query = substr( $query, 0, ( length($query) - 1 ) );
$query .= ");";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute(@params);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return -1;
}
my $sth1 = C4::Context->dbh->prepare("SELECT MAX(template_id) FROM " . $opts{'table_name'} . ";");
my $sth1 = C4::Context->dbh->prepare( "SELECT MAX(template_id) FROM " . $opts{'table_name'} . ";" );
$sth1->execute();
my $template_id = $sth1->fetchrow_array;
$self->{'template_id'} = $template_id;
@ -211,47 +211,58 @@ sub save {
sub get_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my ($attr) = @_;
if (exists($self->{$attr})) {
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
}
sub set_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my %attrs = @_;
foreach my $attrib (keys(%attrs)) {
foreach my $attrib ( keys(%attrs) ) {
$self->{$attrib} = $attrs{$attrib};
};
}
}
sub get_label_position {
my ($self, $start_label) = @_;
my ( $self, $start_label ) = @_;
my $current_label = $self->{'current_label'};
if ($start_label eq 1) {
if ( $start_label eq 1 ) {
$current_label->{'row_count'} = 1;
$current_label->{'col_count'} = 1;
$current_label->{'llx'} = $self->{'left_margin'};
$current_label->{'lly'} = ($self->{'page_height'} - $self->{'top_margin'} - $self->{'label_height'});
$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 {
$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));
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 ) );
$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'}
);
}
}
@ -259,24 +270,25 @@ sub get_next_label_pos {
my $self = shift;
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'));
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->{'col_count'}++;
}
else {
} else {
$current_label->{'llx'} = $self->get_attr('left_margin');
if ($current_label->{'row_count'} eq $self->get_attr('rows')) {
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;
}
return ($current_label->{'llx'}, $current_label->{'lly'}, $new_page);
return ( $current_label->{'llx'}, $current_label->{'lly'}, $new_page );
}
1;

6
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',
@ -44,11 +43,10 @@ sub get_amazon_tld {
);
my $locale = C4::Context->preference('AmazonLocale');
my $tld = $tld{ $locale } || '.com'; # default top level domain is .com
my $tld = $tld{$locale} || '.com'; # default top level domain is .com
return $tld;
}
=head1 NAME
C4::External::Amazon - Functions for retrieving Amazon.com content in Koha

39
C4/External/BakerTaylor.pm vendored
View File

@ -26,7 +26,7 @@ use C4::Context;
use Modern::Perl;
use vars qw(%EXPORT_TAGS $VERSION);
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ -39,25 +39,27 @@ BEGIN {
my ( $user, $pass, $agent, $image_url, $link_url );
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=";
$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=";
$agent = "Koha/$VERSION [en] (Linux)";
#"Mozilla/4.76 [en] (Win98; U)", # if for some reason you want to go stealth, you might prefer this
}
sub image_url {
_initialize();
($user and $pass) or return;
my $isbn = (@_ ? shift : '');
( $user and $pass ) or return;
my $isbn = ( @_ ? shift : '' );
$isbn =~ s/(p|-)//g; # sanitize
return $image_url . $isbn;
}
sub link_url {
_initialize();
my $isbn = (@_ ? shift : '');
my $isbn = ( @_ ? shift : '' );
$isbn =~ s/(p|-)//g; # sanitize
$link_url or return;
return $link_url . $isbn;
@ -65,10 +67,11 @@ sub link_url {
sub content_cafe_url {
_initialize();
($user and $pass) or return;
my $isbn = (@_ ? shift : '');
( $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 {
@ -79,25 +82,27 @@ sub http_jacket_link {
my $alt = "Buy this book";
$image and $image = qq(<img class="btjacket" alt="$alt" src="$image" />);
my $link = &link_url($isbn);
unless ($link) {return $image || '';}
return sprintf qq(<a class="btlink" href="%s">%s</a>),$link,($image||$alt);
unless ($link) { return $image || ''; }
return sprintf qq(<a class="btlink" href="%s">%s</a>), $link, ( $image || $alt );
}
sub availability {
_initialize();
my $isbn = shift or return;
($user and $pass) 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}) {
if ( $result->{Error} ) {
warn "Error returned to " . __PACKAGE__ . " : " . $result->{Error};
}
my $avail = $result->{Availability};
return ($avail and $avail !~ /^false$/i) ? &image_url($isbn) : 0;
return ( $avail and $avail !~ /^false$/i ) ? &image_url($isbn) : 0;
}
1;

34
C4/External/OverDrive.pm vendored
View File

@ -30,21 +30,19 @@ use LWP::UserAgent;
BEGIN {
require Exporter;
our @ISA = qw( Exporter ) ;
our @ISA = qw( Exporter );
our @EXPORT = qw(
GetOverDriveToken
);
}
sub _request {
my ( $request ) = @_;
my ($request) = @_;
my $ua = LWP::UserAgent->new( agent => "Koha " . $Koha::VERSION );
my $response;
eval {
$response = $ua->request( $request ) ;
};
if ( $@ ) {
eval { $response = $ua->request($request); };
if ($@) {
warn "OverDrive request failed: $@";
return;
}
@ -74,24 +72,23 @@ Returns the token ( as "bearer ..." ) or undef on failure.
=cut
sub GetOverDriveToken {
my $key = C4::Context->preference( 'OverDriveClientKey' );
my $secret = C4::Context->preference( 'OverDriveClientSecret' );
my $key = C4::Context->preference('OverDriveClientKey');
my $secret = C4::Context->preference('OverDriveClientSecret');
return unless ( $key && $secret ) ;
return unless ( $key && $secret );
my $cache;
eval { $cache = Koha::Caches->get_instance() };
my $token;
$cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $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;
my $response = _request($request) or return;
if ( $response->header('Content-Type') !~ m!application/json! ) {
warn "Could not connect to OverDrive: " . $response->message;
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;
}

111
C4/External/Syndetics.pm vendored
View File

@ -1,4 +1,5 @@
package C4::External::Syndetics;
# Copyright (C) 2006 LibLime
# <jmf at liblime dot com>
#
@ -65,8 +66,8 @@ sub get_syndetics_index {
return unless ( $isbn || $upc || $oclc );
my $response = _fetch_syndetics_content('INDEX.XML', $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( 'INDEX.XML', $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -77,8 +78,13 @@ 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') {
if (exists $response->{$available_type} && $response->{$available_type} =~ /$available_type/) {
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;
}
}
@ -89,9 +95,9 @@ sub get_syndetics_index {
sub get_syndetics_summary {
my ( $isbn, $upc, $oclc, $syndetics_elements ) = @_;
my $summary_type = exists($syndetics_elements->{'AVSUMMARY'}) ? 'AVSUMMARY.XML' : 'SUMMARY.XML';
my $response = _fetch_syndetics_content($summary_type, $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $summary_type = exists( $syndetics_elements->{'AVSUMMARY'} ) ? 'AVSUMMARY.XML' : 'SUMMARY.XML';
my $response = _fetch_syndetics_content( $summary_type, $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -109,10 +115,10 @@ sub get_syndetics_summary {
}
sub get_syndetics_toc {
my ( $isbn,$upc,$oclc ) = @_;
my ( $isbn, $upc, $oclc ) = @_;
my $response = _fetch_syndetics_content('TOC.XML', $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( 'TOC.XML', $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -120,19 +126,20 @@ sub get_syndetics_toc {
my $xmlsimple = XML::Simple->new();
$response = $xmlsimple->XMLin(
$content,
forcearray => [ qw(Fld970) ],
forcearray => [qw(Fld970)],
) unless !$content;
# manipulate response USMARC VarFlds VarDFlds Notes Fld520 a
my $toc;
$toc = \@{$response->{VarFlds}->{VarDFlds}->{SSIFlds}->{Fld970}} if $response;
$toc = \@{ $response->{VarFlds}->{VarDFlds}->{SSIFlds}->{Fld970} } if $response;
return $toc if $toc;
}
sub get_syndetics_excerpt {
my ( $isbn,$upc,$oclc ) = @_;
my ( $isbn, $upc, $oclc ) = @_;
my $response = _fetch_syndetics_content('DBCHAPTER.XML', $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( 'DBCHAPTER.XML', $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -140,39 +147,43 @@ sub get_syndetics_excerpt {
my $xmlsimple = XML::Simple->new();
$response = $xmlsimple->XMLin(
$content,
forcearray => [ qw(Fld520) ],
forcearray => [qw(Fld520)],
) unless !$content;
# manipulate response USMARC VarFlds VarDFlds Notes Fld520 a
my $excerpt;
$excerpt = \@{$response->{VarFlds}->{VarDFlds}->{Notes}->{Fld520}} if $response;
return XMLout($excerpt, NoEscape => 1) if $excerpt;
$excerpt = \@{ $response->{VarFlds}->{VarDFlds}->{Notes}->{Fld520} } if $response;
return XMLout( $excerpt, NoEscape => 1 ) if $excerpt;
}
sub get_syndetics_reviews {
my ( $isbn,$upc,$oclc,$syndetics_elements ) = @_;
my ( $isbn, $upc, $oclc, $syndetics_elements ) = @_;
my @reviews;
my $review_sources = [
{title => 'Library Journal Review', file => 'LJREVIEW.XML', element => 'LJREVIEW'},
{title => 'Publishers Weekly Review', file => 'PWREVIEW.XML', element => 'PWREVIEW'},
{title => 'School Library Journal Review', file => 'SLJREVIEW.XML', element => 'SLJREVIEW'},
{title => 'CHOICE Review', file => 'CHREVIEW.XML', element => 'CHREVIEW'},
{title => 'Booklist Review', file => 'BLREVIEW.XML', element => 'BLREVIEW'},
{title => 'Horn Book Review', file => 'HBREVIEW.XML', element => 'HBREVIEW'},
{title => 'Kirkus Book Review', file => 'KIREVIEW.XML', element => 'KIREVIEW'},
{title => 'Criticas Review', file => 'CRITICASREVIEW.XML', element => 'CRITICASREVIEW'},
{title => 'Spanish Review', file => 'SPREVIEW.XML', element => 'SPREVIEW'},
{ title => 'Library Journal Review', file => 'LJREVIEW.XML', element => 'LJREVIEW' },
{ title => 'Publishers Weekly Review', file => 'PWREVIEW.XML', element => 'PWREVIEW' },
{ title => 'School Library Journal Review', file => 'SLJREVIEW.XML', element => 'SLJREVIEW' },
{ title => 'CHOICE Review', file => 'CHREVIEW.XML', element => 'CHREVIEW' },
{ title => 'Booklist Review', file => 'BLREVIEW.XML', element => 'BLREVIEW' },
{ title => 'Horn Book Review', file => 'HBREVIEW.XML', element => 'HBREVIEW' },
{ title => 'Kirkus Book Review', file => 'KIREVIEW.XML', element => 'KIREVIEW' },
{ title => 'Criticas Review', file => 'CRITICASREVIEW.XML', element => 'CRITICASREVIEW' },
{ title => 'Spanish Review', file => 'SPREVIEW.XML', element => 'SPREVIEW' },
];
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;
}
my $response = _fetch_syndetics_content($source->{file}, $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( $source->{file}, $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
next;
}
@ -188,7 +199,7 @@ sub get_syndetics_reviews {
# may be present in the reviews, but does mean that any
# <B> and <I> tags used to format the review are also gone.
my $result = $doc->findvalue('//Fld520');
push @reviews, {title => $source->{title}, reviews => [ { content => $result } ]} if $result;
push @reviews, { title => $source->{title}, reviews => [ { content => $result } ] } if $result;
};
if ($@) {
warn "Error parsing Syndetics $source->{title} review";
@ -198,10 +209,10 @@ sub get_syndetics_reviews {
}
sub get_syndetics_editions {
my ( $isbn,$upc,$oclc ) = @_;
my ( $isbn, $upc, $oclc ) = @_;
my $response = _fetch_syndetics_content('FICTION.XML', $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( 'FICTION.XML', $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -210,19 +221,20 @@ sub get_syndetics_editions {
my $xmlsimple = XML::Simple->new();
$response = $xmlsimple->XMLin(
$content,
forcearray => [ qw(Fld020) ],
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;
$similar_items = \@{ $response->{VarFlds}->{VarDFlds}->{NumbCode}->{Fld020} } if $response;
return $similar_items if $similar_items;
}
sub get_syndetics_anotes {
my ( $isbn,$upc,$oclc) = @_;
my ( $isbn, $upc, $oclc ) = @_;
my $response = _fetch_syndetics_content('ANOTES.XML', $isbn, $upc, $oclc);
unless ($response->content_type =~ /xml/) {
my $response = _fetch_syndetics_content( 'ANOTES.XML', $isbn, $upc, $oclc );
unless ( $response->content_type =~ /xml/ ) {
return;
}
@ -231,20 +243,20 @@ sub get_syndetics_anotes {
my $xmlsimple = XML::Simple->new();
$response = $xmlsimple->XMLin(
$content,
forcearray => [ qw(Fld980) ],
forcearray => [qw(Fld980)],
ForceContent => 1,
) unless !$content;
my @anotes;
for my $fld980 (@{$response->{VarFlds}->{VarDFlds}->{SSIFlds}->{Fld980}}) {
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};
if ( ref( $fld980->{a}->{content} ) eq 'ARRAY' ) {
for my $content ( @{ $fld980->{a}->{content} } ) {
push @anotes, { content => $content };
}
}
else {
push @anotes, {content => $fld980->{a}->{content}};
} else {
push @anotes, { content => $fld980->{a}->{content} };
}
}
return \@anotes;
@ -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;

41
C4/Form/MessagingPreferences.pm
View File

@ -71,20 +71,23 @@ adds a settings_updated template variable.
=cut
sub handle_form_action {
my ($query, $target_params, $template, $insert, $categorycode) = @_;
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'} };
OPTION: foreach my $option (@$messaging_options) {
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'} );
@{ $updater->{'message_transport_types'} } = $query->multi_param( $option->{'message_attribute_id'} );
next OPTION unless $updater->{'message_transport_types'};
if ( $option->{'has_digest'} ) {
if ( List::Util::first { $_ == $option->{'message_attribute_id'} } $query->multi_param( 'digest' ) ) {
if ( List::Util::first { $_ == $option->{'message_attribute_id'} } $query->multi_param('digest') ) {
$updater->{'wants_digest'} = 1;
}
}
@ -95,8 +98,9 @@ sub handle_form_action {
}
}
C4::Members::Messaging::SetMessagingPreference( $updater );
C4::Members::Messaging::SetMessagingPreference($updater);
}
# show the success message
$template->param( settings_updated => 1 );
}
@ -116,27 +120,32 @@ C<$template> is the Template::Toolkit object for the response.
=cut
sub set_form_values {
my ($target_params, $template) = @_;
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'} } );
PREF: foreach my $option (@$messaging_options) {
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 }
} ( 0..MAX_DAYS_IN_ADVANCE );
selected => $_ == $days_in_advance
}
foreach my $transport ( keys %{$pref->{'transports'}} ) {
$option->{'transports_'.$transport} = 1;
} ( 0 .. MAX_DAYS_IN_ADVANCE );
}
foreach my $transport ( keys %{ $pref->{'transports'} } ) {
$option->{ 'transports_' . $transport } = 1;
}
$option->{'digest'} = 1 if $pref->{'wants_digest'};
}
$template->param(messaging_preferences => $messaging_options);
$template->param( messaging_preferences => $messaging_options );
}
=head1 TODO

135
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' ) {
if ($marcflavour eq 'MARC21') {
} 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) {
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,47 +108,60 @@ 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 %public = ( (caller)[1] =~ /opac/ ) ? ( public => 1 ) : ();
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];
$HTML5Media{extension} = ( $HTML5Media{srcblock} =~ m/([^.]+)$/ )[0];
}
if ( ( !grep /\Q$HTML5Media{extension}\E/, @HTML5MediaExtensions ) && ( $is_youtube != 1) ) {
if ( ( !grep /\Q$HTML5Media{extension}\E/, @HTML5MediaExtensions ) && ( $is_youtube != 1 ) ) {
next; # not a specified media file
}
# youtube
if ($is_youtube == 1) {
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,75 +191,72 @@ 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);
push( @HTML5Media_sets, \%HTML5Media );
}
}
# parent element
for my $media ( @HTML5Media_sets ) {
if ( ($media->{mime}) && ($media->{mime} =~ /audio/) ) {
for my $media (@HTML5Media_sets) {
if ( ( $media->{mime} ) && ( $media->{mime} =~ /audio/ ) ) {
if ( $HTML5MediaParent ne 'video' ) {
$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') ) ) {
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};
}
}
return (
HTML5MediaEnabled => ( (scalar(@HTML5Media_sets) > 0) && ($HTML5MediaParent) ),
HTML5MediaEnabled => ( ( scalar(@HTML5Media_sets) > 0 ) && ($HTML5MediaParent) ),
HTML5MediaSets => \@HTML5Media_sets,
HTML5MediaParent => $HTML5MediaParent,
HTML5MediaWidth => $HTML5MediaWidth,

19
C4/Heading.pm
View File

@ -76,7 +76,7 @@ sub new_from_field {
$self->{'auth_type'}, $self->{'thesaurus'},
$self->{'search_form'}, $self->{'display_form'},
$self->{'match_type'}
) = $marc_handler->parse_heading($field, $auth );
) = $marc_handler->parse_heading( $field, $auth );
bless $self, $class;
return $self;
@ -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 );

63
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 = {
@ -266,12 +263,11 @@ sub valid_heading_tag {
my $tag = shift;
my $frameworkcode = shift;
my $auth = shift;
my $heading_fields = $auth ? { %$auth_heading_fields } : { %$bib_heading_fields };
my $heading_fields = $auth ? {%$auth_heading_fields} : {%$bib_heading_fields};
if ( exists $heading_fields->{$tag} ) {
return 1;
}
else {
} else {
return 0;
}
@ -287,10 +283,10 @@ sub valid_heading_subfield {
my $subfield = shift;
my $auth = shift;
my $heading_fields = $auth ? { %$auth_heading_fields } : { %$bib_heading_fields };
my $heading_fields = $auth ? {%$auth_heading_fields} : {%$bib_heading_fields};
if ( exists $heading_fields->{$tag} ) {
return 1 if ($heading_fields->{$tag}->{subfields} =~ /$subfield/);
return 1 if ( $heading_fields->{$tag}->{subfields} =~ /$subfield/ );
}
return 0;
}
@ -332,7 +328,7 @@ sub parse_heading {
my $auth = shift;
my $tag = $field->tag;
my $heading_fields = $auth ? { %$auth_heading_fields } : { %$bib_heading_fields };
my $heading_fields = $auth ? {%$auth_heading_fields} : {%$bib_heading_fields};
my $field_info = $heading_fields->{$tag};
my $auth_type = $field_info->{'auth_type'};
@ -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";
}
}

21
C4/Heading/UNIMARC.pm
View File

@ -23,7 +23,6 @@ use warnings;
use MARC::Field;
use C4::Context;
=head1 NAME
C4::Heading::UNIMARC
@ -107,7 +106,7 @@ sub valid_heading_subfield {
my $subfield = shift;
if ( exists $bib_heading_fields->{$tag} ) {
return 1 if ($bib_heading_fields->{$tag}->{subfields} =~ /$subfield/);
return 1 if ( $bib_heading_fields->{$tag}->{subfields} =~ /$subfield/ );
}
return 0;
}
@ -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";
}
}

141
C4/HoldsQueue.pm
View File

@ -35,7 +35,8 @@ use List::Util qw( shuffle );
use List::MoreUtils qw( any );
use Algorithm::Munkres qw();
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -51,7 +52,6 @@ BEGIN {
);
}
=head1 FUNCTIONS
=head2 TransportCostMatrix
@ -63,10 +63,10 @@ Returns Transport Cost Matrix as a hashref <to branch code> => <from branch code
=cut
sub TransportCostMatrix {
my ( $params ) = @_;
my ($params) = @_;
my $dbh = C4::Context->dbh;
my $transport_costs = $dbh->selectall_arrayref("SELECT * FROM transport_cost",{ Slice => {} });
my $transport_costs = $dbh->selectall_arrayref( "SELECT * FROM transport_cost", { Slice => {} } );
my $today = dt_from_string();
my %transport_cost_matrix;
@ -97,17 +97,17 @@ 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) {
my $cost = $_->{cost};
my $from = $_->{frombranch};
my $to = $_->{tobranch};
if ($_->{disable_transfer}) {
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();
@ -313,7 +308,7 @@ sub GetPendingHoldRequestsForBib {
my $sth = $dbh->prepare($request_query);
$sth->execute($biblionumber);
my $requests = $sth->fetchall_arrayref({});
my $requests = $sth->fetchall_arrayref( {} );
return $requests;
}
@ -337,7 +332,7 @@ to fill a hold request if and only if:
=cut
sub GetItemsAvailableToFillHoldRequestsForBib {
my ($biblionumber, $branches_to_use) = @_;
my ( $biblionumber, $branches_to_use ) = @_;
my $dbh = C4::Context->dbh;
my $items_query = "SELECT items.itemnumber, homebranch, holdingbranch, itemtypes.itemtype AS itype
@ -375,20 +370,22 @@ sub GetItemsAvailableToFillHoldRequestsForBib {
AND items.biblionumber = ?
AND branchtransfers.itemnumber IS NULL";
my @params = ($biblionumber, $biblionumber, $biblionumber);
if ($branches_to_use && @$branches_to_use) {
$items_query .= " AND holdingbranch IN (" . join (",", map { "?" } @$branches_to_use) . ")";
my @params = ( $biblionumber, $biblionumber, $biblionumber );
if ( $branches_to_use && @$branches_to_use ) {
$items_query .= " AND holdingbranch IN (" . join( ",", map { "?" } @$branches_to_use ) . ")";
push @params, @$branches_to_use;
}
my $sth = $dbh->prepare($items_query);
$sth->execute(@params);
my $itm = $sth->fetchall_arrayref({});
return [ grep {
my $rule = C4::Circulation::GetBranchItemRule($_->{homebranch}, $_->{itype});
my $itm = $sth->fetchall_arrayref( {} );
return [
grep {
my $rule = C4::Circulation::GetBranchItemRule( $_->{homebranch}, $_->{itype} );
$_->{holdallowed} = $rule->{holdallowed};
$_->{hold_fulfillment_policy} = $rule->{hold_fulfillment_policy};
} @{$itm} ];
} @{$itm}
];
}
=head2 _checkHoldPolicy
@ -598,10 +595,11 @@ RETRY:
# end.
$inf = $max * $num_tasks + 1;
my @m0 = map {[(undef) x $num_tasks]} (1..$num_agents);
my @m0 = map { [ (undef) x $num_tasks ] } ( 1 .. $num_agents );
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
@ -711,7 +709,7 @@ RETRY:
=cut
sub MapItemsToHoldRequests {
my ($hold_requests, $available_items, $branches_to_use, $transport_cost_matrix) = @_;
my ( $hold_requests, $available_items, $branches_to_use, $transport_cost_matrix ) = @_;
# handle trival cases
return unless scalar(@$hold_requests) > 0;
@ -719,7 +717,7 @@ sub MapItemsToHoldRequests {
map { $_->{_object} = Koha::Items->find( $_->{itemnumber} ) } @$available_items;
my $libraries = {};
map { $libraries->{$_->id} = $_ } Koha::Libraries->search->as_list;
map { $libraries->{ $_->id } = $_ } Koha::Libraries->search->as_list;
# group available items by itemnumber
my %items_by_itemnumber = map { $_->{itemnumber} => $_ } @$available_items;
@ -735,14 +733,12 @@ 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;
my $patron = Koha::Patrons->find($request->{borrowernumber});
my $patron = Koha::Patrons->find( $request->{borrowernumber} );
next if $patron->category->exclude_from_local_holds_priority;
my $local_hold_match;
@ -753,24 +749,19 @@ 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} }
and not exists $allocated_items{ $item->{itemnumber} }
and not $request->{allocated})
and not $request->{allocated} )
{
$item_map{ $item->{itemnumber} } = {
borrowernumber => $request->{borrowernumber},
@ -801,7 +792,8 @@ sub MapItemsToHoldRequests {
next if $request->{allocated};
# is this an item-level request?
if (defined($request->{itemnumber})) {
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--;
}
@ -850,12 +843,12 @@ sub MapItemsToHoldRequests {
return \%item_map unless keys %items_by_branch;
# now handle the title-level requests
$num_items_remaining = scalar(@$available_items) - scalar(keys %allocated_items);
$num_items_remaining = scalar(@$available_items) - scalar( keys %allocated_items );
my $pull_branches;
foreach my $request (@$hold_requests) {
last if $num_items_remaining == 0;
next if $request->{allocated};
next if defined($request->{itemnumber}); # already handled these
next if defined( $request->{itemnumber} ); # already handled these
# HoldsQueuePrioritizeBranch check
# ********************************
@ -880,16 +873,16 @@ sub MapItemsToHoldRequests {
last;
}
}
# End HoldsQueuePrioritizeBranch check
# ********************************
# Not found yet, fall back to basics
unless ($itemnumber) {
if ($branches_to_use) {
$pull_branches = $branches_to_use;
} else {
$pull_branches = [keys %items_by_branch];
$pull_branches = [ keys %items_by_branch ];
}
$holdingbranch ||= $pull_branches->[0]; # We set this as the first from the list of pull branches
# unless we set it above to the pickupbranch or the least cost branch
@ -913,7 +906,7 @@ sub MapItemsToHoldRequests {
}
# Now try items from the least cost branch based on the transport cost matrix or StaticHoldsQueueWeight
unless ( $itemnumber || !$holdingbranch) {
unless ( $itemnumber || !$holdingbranch ) {
foreach my $current_item ( @{ $items_by_branch{$holdingbranch} } ) {
next unless _can_item_fill_request( $current_item, $request, $libraries );
@ -923,13 +916,13 @@ sub MapItemsToHoldRequests {
}
# Now try for items for any item that can fill this hold
unless ( $itemnumber ) {
unless ($itemnumber) {
foreach my $branch (@$pull_branches) {
my $holding_branch_items = $items_by_branch{$branch}
or next;
foreach my $item (@$holding_branch_items) {
if( _can_item_fill_request( $item, $request, $libraries ) ){
if ( _can_item_fill_request( $item, $request, $libraries ) ) {
$itemnumber = $item->{itemnumber};
$holdingbranch = $branch;
last;
@ -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
@ -1007,14 +997,14 @@ sub CreatePicklistFromItemMap {
my $dbh = C4::Context->dbh;
my $sth_load=$dbh->prepare("
my $sth_load = $dbh->prepare( "
INSERT INTO tmp_holdsqueue (biblionumber,itemnumber,barcode,surname,firstname,phone,borrowernumber,
cardnumber,reservedate,title, itemcallnumber,
holdingbranch,pickbranch,notes, item_level_request)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
");
" );
foreach my $itemnumber (sort keys %$item_map) {
foreach my $itemnumber ( sort keys %$item_map ) {
my $mapped_item = $item_map->{$itemnumber};
my $biblionumber = $mapped_item->{biblionumber};
my $borrowernumber = $mapped_item->{borrowernumber};
@ -1028,18 +1018,20 @@ sub CreatePicklistFromItemMap {
my $barcode = $item->barcode;
my $itemcallnumber = $item->itemcallnumber;
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
my $cardnumber = $patron->cardnumber;
my $surname = $patron->surname;
my $firstname = $patron->firstname;
my $phone = $patron->phone;
my $biblio = Koha::Biblios->find( $biblionumber );
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
);
}
}
@ -1086,15 +1078,13 @@ sub load_branches_to_pull_from {
my @branches_to_use;
unless ( $use_transport_cost_matrix ) {
unless ($use_transport_cost_matrix) {
my $static_branch_list = C4::Context->preference("StaticHoldsQueueWeight");
@branches_to_use = map { _trim($_) } split( /,/, $static_branch_list )
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;
@ -1114,17 +1101,17 @@ sub load_branches_to_pull_from {
sub least_cost_branch {
#$from - arrayref
my ($to, $from, $transport_cost_matrix) = @_;
my ( $to, $from, $transport_cost_matrix ) = @_;
# Nothing really spectacular: supply to branch, a list of potential from branches
# and find the minimum from - to value from the transport_cost_matrix
return $from->[0] if ( @$from == 1 && $transport_cost_matrix->{$to}{$from->[0]}->{disable_transfer} != 1 );
return $from->[0] if ( @$from == 1 && $transport_cost_matrix->{$to}{ $from->[0] }->{disable_transfer} != 1 );
# If the pickup library is in the list of libraries to pull from,
# return that library right away, it is obviously the least costly
return ($to) if any { $_ eq $to } @$from;
my ($least_cost, @branch);
my ( $least_cost, @branch );
foreach (@$from) {
my $cell = $transport_cost_matrix->{$to}{$_};
next if $cell->{disable_transfer};
@ -1132,7 +1119,7 @@ sub least_cost_branch {
my $cost = $cell->{cost};
next unless defined $cost; # XXX should this be reported?
unless (defined $least_cost) {
unless ( defined $least_cost ) {
$least_cost = $cost;
push @branch, $_;
next;
@ -1140,7 +1127,7 @@ sub least_cost_branch {
next if $cost > $least_cost;
if ($cost == $least_cost) {
if ( $cost == $least_cost ) {
push @branch, $_;
next;
}
@ -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};

120
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";
@ -138,12 +141,14 @@ sub GetAvailability {
} else {
my $status;
my $msg;
my $items = Koha::Items->search({ biblionumber => $id });
if ($items->count) {
my $items = Koha::Items->search( { biblionumber => $id } );
if ( $items->count ) {
# Open XML
$out .= " <dlf:record>\n";
$out .= " <dlf:bibliographic id=\"" .$id. "\" />\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";
@ -210,8 +219,8 @@ sub GetRecords {
foreach my $biblionumber ( split( / /, $cgi->param('id') ) ) {
# Get the biblioitem from the biblionumber
my $biblio = Koha::Biblios->find( $biblionumber );
unless ( $biblio ) {
my $biblio = Koha::Biblios->find($biblionumber);
unless ($biblio) {
push @records, { code => "RecordNotFound" };
next;
}
@ -253,15 +262,16 @@ sub GetRecords {
$item{'homebranchname'} = $home_library ? $home_library->branchname : '';
$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 });
if ( $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};
}
}
if ($item->itype) {
my $itemtype = Koha::ItemTypes->find($item->itype);
if ( $item->itype ) {
my $itemtype = Koha::ItemTypes->find( $item->itype );
if ($itemtype) {
$item{itype_description} = $itemtype->description;
}
@ -354,19 +364,22 @@ sub LookupPatron {
my ($cgi) = @_;
my $id = $cgi->param('id');
if(!$id) {
if ( !$id ) {
return { message => 'PatronNotFound' };
}
my $patrons;
my $passed_id_type = $cgi->param('id_type');
if($passed_id_type) {
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);
last if ( $patrons->count );
}
}
unless ( $patrons->count ) {
@ -394,16 +407,15 @@ sub AuthenticatePatron {
my ($cgi) = @_;
my $username = $cgi->param('username');
my $password = $cgi->param('password');
my ($status, $cardnumber, $userid, $patron) = C4::Auth::checkpw( $username, $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' };
}
}
@ -437,12 +449,13 @@ sub GetPatronInfo {
# Get Member details
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# 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 );
@ -512,18 +527,22 @@ sub GetPatronInfo {
my $pending_checkouts = $patron->pending_checkouts;
if ($page || $per_page) {
if ( $page || $per_page ) {
$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'} = [
@ -579,7 +599,7 @@ sub GetPatronStatus {
# Get Member details
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# Return the results
@ -609,10 +629,11 @@ sub GetServices {
# Get the member, or return an error code if not found
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
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);
@ -623,9 +644,9 @@ sub GetServices {
# Reserve level management
my $biblionumber = $item->biblionumber;
my $canbookbereserved = CanBookBeReserved( $borrower, $biblionumber );
if ($canbookbereserved->{status} eq 'OK') {
if ( $canbookbereserved->{status} eq 'OK' ) {
push @availablefor, 'title level hold';
my $canitembereserved = IsAvailableForItemLevelRequest($item, $patron);
my $canitembereserved = IsAvailableForItemLevelRequest( $item, $patron );
if ($canitembereserved) {
push @availablefor, 'item level hold';
}
@ -682,7 +703,7 @@ sub RenewLoan {
# Get borrower infos or return an error code
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# Get the item, or return an error code
@ -709,8 +730,9 @@ 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->{date_due} = dt_from_string( $issue->date_due )->strftime('%Y-%m-%d %H:%M');
$out->{'success'} = $renewal[0];
$out->{'error'} = $renewal[1];
@ -743,10 +765,9 @@ sub HoldTitle {
# Get the borrower or return an error code
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
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;
@ -756,16 +777,17 @@ sub HoldTitle {
# Get the biblio record, or return an error code
my $biblionumber = $cgi->param('bib_id');
my $biblio = Koha::Biblios->find( $biblionumber );
my $biblio = Koha::Biblios->find($biblionumber);
return { code => 'RecordNotFound' } unless $biblio;
my @hostitems = get_hostitemnumbers_of($biblionumber);
my @itemnumbers;
if (@hostitems){
push(@itemnumbers, @hostitems);
if (@hostitems) {
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' };
@ -789,7 +811,7 @@ sub HoldTitle {
my $destination = Koha::Libraries->find($branch);
return { code => 'libraryNotPickupLocation' } unless $destination->pickup_location;
return { code => 'cannotBeTransferred' } unless $biblio->can_be_transferred({ to => $destination });
return { code => 'cannotBeTransferred' } unless $biblio->can_be_transferred( { to => $destination } );
my $resdate = $cgi->param('start_date');
my $expdate = $cgi->param('expiry_date');
@ -798,7 +820,7 @@ sub HoldTitle {
# $branch, $borrowernumber, $biblionumber,
# $constraint, $bibitems, $priority, $resdate, $expdate, $notes,
# $title, $checkitem, $found
my $priority= C4::Reserves::CalculatePriority( $biblionumber );
my $priority = C4::Reserves::CalculatePriority($biblionumber);
AddReserve(
{
branchcode => $branch,
@ -814,7 +836,7 @@ sub HoldTitle {
# Hashref building
my $out;
$out->{'title'} = $title;
my $library = Koha::Libraries->find( $branch );
my $library = Koha::Libraries->find($branch);
$out->{'pickup_location'} = $library ? $library->branchname : '';
# TODO $out->{'date_available'} = '';
@ -849,7 +871,7 @@ sub HoldItem {
# Get the borrower or return an error code
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# If borrower is restricted return an error code
@ -861,7 +883,7 @@ sub HoldItem {
# Get the biblio or return an error code
my $biblionumber = $cgi->param('bib_id');
my $biblio = Koha::Biblios->find( $biblionumber );
my $biblio = Koha::Biblios->find($biblionumber);
return { code => 'RecordNotFound' } unless $biblio;
my $title = $biblio ? $biblio->title : '';
@ -907,7 +929,7 @@ sub HoldItem {
# Hashref building
my $out;
my $library = Koha::Libraries->find( $branch );
my $library = Koha::Libraries->find($branch);
$out->{'pickup_location'} = $library ? $library->branchname : '';
# TODO $out->{'date_available'} = '';
@ -933,12 +955,12 @@ sub CancelHold {
# Get the borrower or return an error code
my $borrowernumber = $cgi->param('patron_id');
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return { code => 'PatronNotFound' } unless $patron;
# Get the reserve or return an error code
my $reserve_id = $cgi->param('item_id');
my $hold = Koha::Holds->find( $reserve_id );
my $hold = Koha::Holds->find($reserve_id);
return { code => 'RecordNotFound' } unless $hold;
# Check if reserve belongs to the borrower and if it is in a state which allows cancellation
@ -962,7 +984,7 @@ sub _availability {
my ($itemnumber) = @_;
my $item = Koha::Items->find($itemnumber);
unless ( $item ) {
unless ($item) {
return ( undef, __('unknown'), __('Error: could not retrieve availability for this ID'), undef );
}

673
C4/ImportBatch.pm
View File

File diff suppressed because it is too large Load Diff

699
C4/ImportExportFramework.pm
View File

File diff suppressed because it is too large Load Diff

46
C4/InstallAuth.pm
View File

@ -29,7 +29,8 @@ use C4::Templates;
use Koha::Session;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
@ISA = qw(Exporter);
@EXPORT_OK = qw(
@ -104,18 +105,18 @@ Templates.pm module.
sub get_template_and_user {
my $in = shift;
my $query = $in->{'query'};
my $language =_get_template_language($query->cookie('KohaOpacLanguage'));
my $path = C4::Context->config('intrahtdocs'). "/prog/". $language;
my $language = _get_template_language( $query->cookie('KohaOpacLanguage') );
my $path = C4::Context->config('intrahtdocs') . "/prog/" . $language;
my $tmplbase = $in->{template_name};
my $filename = "$path/modules/" . $tmplbase;
my $interface = 'intranet';
my $template = C4::Templates->new( $interface, $filename, $tmplbase, $query);
my $template = C4::Templates->new( $interface, $filename, $tmplbase, $query );
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_userid', '' );
$in->{query}->param( 'login_password', '' );
}
my ( $user, $cookie, $sessionID, $flags ) = checkauth(
@ -155,7 +156,7 @@ sub get_template_and_user {
my $minPasswordLength = C4::Context->preference('minPasswordLength');
$minPasswordLength = 3 if not $minPasswordLength or $minPasswordLength < 3;
$template->param(minPasswordLength => $minPasswordLength,);
$template->param( minPasswordLength => $minPasswordLength, );
}
return ( $template, $borrowernumber, $cookie );
}
@ -232,7 +233,7 @@ has authenticated.
sub checkauth {
my $query = shift;
# $authnotrequired will be set for scripts which will run without authentication
# $authnotrequired will be set for scripts which will run without authentication
my $authnotrequired = shift;
my $flagsrequired = shift;
my $type = shift;
@ -251,7 +252,7 @@ sub checkauth {
my $sessionID = $query->cookie("CGISESSID");
my $session = Koha::Session->get_session( { sessionID => $sessionID, storage_method => 'file' } );
if ( $session ) {
if ($session) {
if ( $session->param('cardnumber') ) {
C4::Context->set_userenv(
$session->param('number'),
@ -276,7 +277,8 @@ sub checkauth {
}
}
if ($logout || !$session) {
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,11 +372,12 @@ 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';
my $template = C4::Templates->new( $interface, $filename, '', $query);
my $template = C4::Templates->new( $interface, $filename, '', $query );
$template->param(
INPUTS => \@inputs,
@ -381,11 +385,11 @@ sub checkauth {
$template->param( login => 1 );
$template->param( loginprompt => 1 ) unless $info{'nopermission'};
if ($info{'invalid_username_or_password'} && $info{'invalid_username_or_password'} == 1) {
$template->param( 'invalid_username_or_password' => $info{'invalid_username_or_password'});
if ( $info{'invalid_username_or_password'} && $info{'invalid_username_or_password'} == 1 ) {
$template->param( 'invalid_username_or_password' => $info{'invalid_username_or_password'} );
}
unless ( $sessionID ) {
unless ($sessionID) {
$session = Koha::Session->get_session( { storage_method => 'file' } );
$sessionID = $session->id;
}

255
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,21 +84,31 @@ 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' ) {
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"');
$self->{'dbh'}->{'mysql_enable_utf8'}=1;
$self->{'dbh'}->{'mysql_enable_utf8'} = 1;
bless $self, $class;
return $self;
@ -124,16 +136,19 @@ 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') {
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);
opendir($dir_h, $dir) or warn "cannot open English MARC frameworks directory $dir";
$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;
}
}
@ -166,10 +181,10 @@ sub marc_framework_sql_list {
} else {
open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
my $line = <$fh>;
$line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
$line = Encode::encode( 'UTF-8', $line ) unless ( Encode::is_utf8($line) );
@lines = split /\n/, $line;
}
my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
my $mandatory = ( $requirelevel =~ /(mandatory|requi|oblig|necess)/i );
push @frameworklist,
{
'fwkname' => $name,
@ -183,12 +198,12 @@ sub marc_framework_sql_list {
sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
$cell{"frameworks"} = \@fwks;
$cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
$cell{"label"} = ( $requirelevel =~ /(mandatory|requi|oblig|necess)/i ) ? 'mandatory' : 'optional';
$cell{"code"} = lc($requirelevel);
push @fwklist, \%cell;
}
return ($defaulted_to_en, \@fwklist);
return ( $defaulted_to_en, \@fwklist );
}
=head2 sample_data_sql_list
@ -211,14 +226,15 @@ sub sample_data_sql_list {
undef $/;
my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
my $dir_h;
unless (opendir( $dir_h, $dir )) {
if ($lang eq 'en') {
unless ( opendir( $dir_h, $dir ) ) {
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";
opendir($dir_h, $dir) or warn "cannot open English sample data directory $dir";
opendir( $dir_h, $dir ) or warn "cannot open English sample data directory $dir";
$defaulted_to_en = 1;
}
}
@ -251,10 +267,10 @@ sub sample_data_sql_list {
} else {
open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
my $line = <$fh>;
$line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
$line = Encode::encode( 'UTF-8', $line ) unless ( Encode::is_utf8($line) );
@lines = split /\n/, $line;
}
my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
my $mandatory = ( $requirelevel =~ /(mandatory|requi|oblig|necess)/i );
push @frameworklist,
{
'fwkname' => $name,
@ -267,12 +283,12 @@ sub sample_data_sql_list {
my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
$cell{"frameworks"} = \@fwks;
$cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
$cell{"label"} = ( $requirelevel =~ /(mandatory|requi|oblig|necess)/i ) ? 'mandatory' : 'optional';
$cell{"code"} = lc($requirelevel);
push @levellist, \%cell;
}
return ($defaulted_to_en, \@levellist);
return ( $defaulted_to_en, \@levellist );
}
=head2 load_db_schema
@ -350,7 +366,7 @@ sub load_sql_in_order {
my @bb = split /\/|\\/, ($b);
$aa[-1] cmp $bb[-1]
} @sql_list;
my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
$request->execute;
my ($systempreference) = $request->fetchrow;
$systempreference = '' unless defined $systempreference; # avoid warning
@ -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 =
@ -418,7 +435,7 @@ sub load_sql_in_order {
my $rq = $self->{'dbh'}->prepare($string);
$rq->execute;
}
return ($fwk_language, \@list);
return ( $fwk_language, \@list );
}
=head2 set_marcflavour_syspref
@ -463,15 +480,19 @@ 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')) {
if ( C4::Context->preference('Version') ) {
warn "UPDATE Version";
my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
my $finish = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
$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");
@ -516,19 +539,22 @@ sub process_yml_table {
my ($table) = @_;
my $table_name = ( keys %$table )[0]; # table name
my @rows = @{ $table->{$table_name}->{rows} }; #
my @columns = ( sort keys %{$rows[0]} ); # column names
my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
my @columns = ( sort keys %{ $rows[0] } ); # column names
my $fields = join ",", map { sprintf( "`%s`", $_ ) } @columns; # idem, joined
my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
my $placeholders = '(' . join( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
my @values;
foreach my $row ( @rows ) {
push @values, [ map {
foreach my $row (@rows) {
push @values, [
map {
my $col = $_;
( @multiline and grep { $_ eq $col } @multiline )
? join "\r\n", @{$row->{$col}} # join multiline values
? join "\r\n", @{ $row->{$col} } # join multiline values
: $row->{$col};
} @columns ];
} @columns
];
}
return { query => $query, placeholders => $placeholders, values => \@values };
}
@ -550,7 +576,7 @@ sub load_sql {
my $filename = shift;
my $error;
my $dbh = $self->{ dbh };
my $dbh = $self->{dbh};
my $dup_stderr;
do {
@ -564,18 +590,18 @@ sub load_sql {
sql => $filename,
);
};
}
else { # YAML files
} else { # YAML files
eval {
my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
my $yaml = YAML::XS::LoadFile($filename); # Load YAML
for my $table ( @{ $yaml->{'tables'} } ) {
my $query_info = process_yml_table($table);
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;
$query .= join ', ', ($placeholders) x scalar @$values;
$dbh->do( $query, undef, @all_rows_values );
}
for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
@ -583,12 +609,13 @@ sub load_sql {
}
};
}
if ($@){
if ($@) {
warn "Something went wrong loading file $filename ($@)";
}
};
# errors thrown while loading installer data should be logged
if( $dup_stderr ) {
if ($dup_stderr) {
warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
$error = $dup_stderr;
}
@ -614,12 +641,13 @@ 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);
my ( $defaulted_to_en, $list ) = $self->sample_data_sql_list($lang);
# warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
my @found;
foreach my $frameworklist ( @$list ) {
push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
foreach my $frameworklist (@$list) {
push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{ $frameworklist->{'frameworks'} };
}
# warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
@ -639,7 +667,7 @@ sub primary_key_exists {
my $dbh = C4::Context->dbh;
my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
my $exists;
if( $key_name ){
if ($key_name) {
$sql .= 'AND column_name = ? ' if $key_name;
($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
} else {
@ -652,14 +680,14 @@ sub primary_key_exists {
sub foreign_key_exists {
my ( $table_name, $constraint_name ) = @_;
my $dbh = C4::Context->dbh;
my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
my ( undef, $infos ) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
}
sub unique_key_exists {
my ( $table_name, $constraint_name ) = @_;
my $dbh = C4::Context->dbh;
my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
my ( undef, $infos ) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
return $infos =~ m|UNIQUE KEY `$constraint_name`|;
}
@ -709,17 +737,17 @@ sub version_from_file {
sub get_db_entries {
my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
my @files = sort grep { m|\.pl$| && !m|skeleton\.pl$| } readdir $dh;
my @need_update;
for my $file ( @files ) {
my $version = version_from_file( $file );
for my $file (@files) {
my $version = version_from_file($file);
unless ( $version ) {
unless ($version) {
warn "Invalid db_rev found: " . $file;
next
next;
}
next unless CheckVersion( $version );
next unless CheckVersion($version);
push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
}
@ -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 );
};
@ -759,7 +786,7 @@ sub run_db_rev {
time => POSIX::strftime( "%H:%M:%S", localtime ),
error => $error
};
$db_entry->{output} = generate_output_db_entry($db_entry, $out);
$db_entry->{output} = generate_output_db_entry( $db_entry, $out );
return $db_entry;
}
@ -769,24 +796,25 @@ sub update {
my $force = $params->{force} || 0;
my ( @done, @errors );
for my $file ( @$files ) {
for my $file (@$files) {
my $db_entry = run_db_rev($file);
if ( $db_entry->{error} ) {
push @errors, $db_entry;
$force ? next : last ;
$force ? next : last;
# We stop the update if an error occurred!
}
SetVersion($db_entry->{version});
SetVersion( $db_entry->{version} );
push @done, $db_entry;
}
return { success => \@done, error => \@errors };
}
sub generate_output_db_entry {
my ( $db_entry ) = @_;
my ($db_entry) = @_;
my $description = $db_entry->{description};
my $output = $db_entry->{output};
@ -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"
@ -802,22 +831,27 @@ sub generate_output_db_entry {
my @output;
if ( $DBversion ) {
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);
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);
push @output, sprintf( 'DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time );
}
}
if ($exec_output) {
foreach my $line (split /\n/, $exec_output) {
foreach my $line ( split /\n/, $exec_output ) {
push @output, sprintf "\t%s", $line;
}
}
@ -831,21 +865,21 @@ sub get_atomic_updates {
}
sub run_atomic_updates {
my ( $files ) = @_;
my ($files) = @_;
my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
my ( @done, @errors );
for my $file ( @$files ) {
for my $file (@$files) {
my $filepath = $update_dir . $file;
my $atomic_update;
if ( $file =~ m{\.perl$} ) {
my $code = read_file( $filepath );
my ( $out, $err ) = ('', '');
my $code = read_file($filepath);
my ( $out, $err ) = ( '', '' );
{
open my $oldout, qw{>&}, "STDOUT";
close STDOUT;
open STDOUT,'>:encoding(utf8)', \$out;
open STDOUT, '>:encoding(utf8)', \$out;
my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
my $dbh = C4::Context->dbh;
eval $code; ## no critic (StringyEval)
@ -862,7 +896,6 @@ sub run_atomic_updates {
time => POSIX::strftime( "%H:%M:%S", localtime ),
};
$atomic_update->{output} =
$out
? [ split "\n", $out ]
@ -893,27 +926,31 @@ 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;
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="";
$id = "";
}
}
}
=head2 TransformToNum
Transform the Koha version from a 4 parts string
@ -934,15 +971,18 @@ set the DBversion in the systempreferences
=cut
sub SetVersion {
return if $_[0]=~ /XXX$/;
return if $_[0] =~ /XXX$/;
#you are testing a patch with a db revision; do not change version
my $kohaversion = TransformToNum($_[0]);
my $kohaversion = TransformToNum( $_[0] );
my $dbh = C4::Context->dbh;
if (C4::Context->preference('Version')) {
my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
if ( C4::Context->preference('Version') ) {
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;
@ -995,7 +1036,7 @@ sub CheckVersion {
return 1 if ( $proposed_version =~ m/XXX/ );
if ( C4::Context->preference("Version") < $version_number
&& $version_number <= TransformToNum( $Koha::VERSION ) )
&& $version_number <= TransformToNum($Koha::VERSION) )
{
return 1;
}
@ -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';
|);
|
);
}
}
@ -1036,7 +1083,7 @@ sub has_non_dynamic_row_format {
my ($class) = @_;
my $database = C4::Context->config('database');
my $count = 0;
if ($database){
if ($database) {
my $dbh = C4::Context->dbh;
my $sql = q#
SELECT count(table_name)
@ -1045,7 +1092,7 @@ sub has_non_dynamic_row_format {
table_schema = ?
AND row_format != "Dynamic"
#;
( $count ) = $dbh->selectrow_array($sql, undef, $database);
($count) = $dbh->selectrow_array( $sql, undef, $database );
}
return $count;
}

24
C4/Installer/PerlModules.pm
View File

@ -15,16 +15,16 @@ sub new {
};
my $type = ref($invocant) || $invocant;
bless ($self, $type);
bless( $self, $type );
return $self;
}
sub prereqs {
my $self = shift;
unless (defined $self->{prereqs}) {
unless ( defined $self->{prereqs} ) {
my $filename = $INC{'C4/Installer/PerlModules.pm'};
my $path = dirname(dirname(dirname($filename)));
my $path = dirname( dirname( dirname($filename) ) );
$self->{prereqs} = Module::CPANfile->load("$path/cpanfile")->prereqs;
}
@ -36,7 +36,7 @@ sub prereq_pm {
my $prereq_pm = {};
my $reqs = $self->prereqs->merged_requirements;
foreach my $module ($reqs->required_modules) {
foreach my $module ( $reqs->required_modules ) {
$prereq_pm->{$module} = $reqs->requirements_for_module($module);
}
@ -51,10 +51,10 @@ sub versions_info {
$self->{'upgrade_pm'} = [];
$self->{'current_pm'} = [];
foreach my $phase ($self->prereqs->phases) {
foreach my $type ($self->prereqs->types_in($phase)) {
my $reqs = $self->prereqs->requirements_for($phase, $type);
foreach my $module (sort $reqs->required_modules) {
foreach my $phase ( $self->prereqs->phases ) {
foreach my $type ( $self->prereqs->types_in($phase) ) {
my $reqs = $self->prereqs->requirements_for( $phase, $type );
foreach my $module ( sort $reqs->required_modules ) {
my $module_infos = {
cur_ver => 0,
required => $type eq 'requires',
@ -67,14 +67,14 @@ sub versions_info {
} elsif ( $req->[0] eq '<=' || $req->[0] eq '<' ) {
$module_infos->{max_ver} = $req->[1];
} else {
push @{$module_infos->{exc_ver}}, $req->[1];
push @{ $module_infos->{exc_ver} }, $req->[1];
}
}
my $attr;
{
# ignore warnings from noisy modules
local $SIG{__WARN__} = sub {};
local $SIG{__WARN__} = sub { };
eval "require $module";
}
if ($@) {
@ -82,7 +82,7 @@ sub versions_info {
} else {
my $pkg_version = $module->can("VERSION") ? $module->VERSION : 0;
$module_infos->{cur_ver} = $pkg_version;
if ($reqs->accepts_module($module => $pkg_version)) {
if ( $reqs->accepts_module( $module => $pkg_version ) ) {
$attr = 'current_pm';
} else {
$attr = 'upgrade_pm';
@ -96,7 +96,7 @@ sub versions_info {
}
sub get_attr {
return $_[0]->{$_[1]};
return $_[0]->{ $_[1] };
}
1;

27
C4/Installer/UpgradeBackup.pm
View File

@ -48,33 +48,36 @@ sub backup_changed_files {
my $inc_uninstall = shift;
my $cwd = cwd();
foreach my $sourceroot (sort keys %$from_to) {
foreach my $sourceroot ( sort keys %$from_to ) {
my $targetroot = $from_to->{$sourceroot};
my $currdir = File::Spec->catdir($cwd, $sourceroot);
my $currdir = File::Spec->catdir( $cwd, $sourceroot );
next unless -d $currdir;
chdir $currdir or die "could not change to $currdir: $!";
# expand path
find(sub {
find(
sub {
return unless -f $_;
my $filename = $_;
my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
my $targetfile = File::Spec->catfile($targetdir, $filename);
my $sourcedir = File::Spec->catdir($currdir, $File::Find::dir);
my $sourcefile = File::Spec->catfile($sourcedir, $filename);
my $targetdir = File::Spec->catdir( $targetroot, $File::Find::dir );
my $targetfile = File::Spec->catfile( $targetdir, $filename );
my $sourcedir = File::Spec->catdir( $currdir, $File::Find::dir );
my $sourcefile = File::Spec->catfile( $sourcedir, $filename );
if (-f $targetfile) {
my ($size) = (stat $sourcefile)[7];
if ( -f $targetfile ) {
my ($size) = ( stat $sourcefile )[7];
my $backup = $targetfile . $suffix;
unless (-s $targetfile == $size and not compare($sourcefile, $targetfile)) {
unless ( -s $targetfile == $size and not compare( $sourcefile, $targetfile ) ) {
print "Backed up $targetfile to $backup\n";
File::Copy::copy($targetfile, $backup);
File::Copy::copy( $targetfile, $backup );
}
}
}, ".");
},
"."
);
}
}

70
C4/ItemCirculationAlertPreference.pm
View File

@ -31,13 +31,10 @@ our $AUTOLOAD;
our $valid = sub {
my $opts = shift;
for (qw(branchcode categorycode item_type notification)) {
exists($opts->{$_}) || croak("'$_' is a required parameter.");
exists( $opts->{$_} ) || croak("'$_' is a required parameter.");
}
};
=head1 NAME
C4::ItemCirculationAlertPreference - manage preferences for sending alerts
@ -93,13 +90,10 @@ object. The database is not affected by this method.
=cut
sub new {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
bless $opts => $class;
}
=head3 C4::ItemCirculationAlertPreference->create(\%opts)
This will find or create an item circulation alert preference. You must pass
@ -129,7 +123,7 @@ This can be "CHECKIN" or "CHECKOUT"
=cut
sub create {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
$valid->($opts);
my $dbh = C4::Context->dbh;
my $prefs = $dbh->selectall_arrayref(
@ -146,7 +140,7 @@ sub create {
$opts->{notification},
);
if (@$prefs) {
return $class->new($prefs->[0]);
return $class->new( $prefs->[0] );
} else {
my $success = $dbh->do(
"INSERT INTO item_circulation_alert_preferences
@ -159,7 +153,7 @@ sub create {
);
if ($success) {
my $self = {
id => $dbh->last_insert_id(undef, undef, undef, undef),
id => $dbh->last_insert_id( undef, undef, undef, undef ),
branchcode => $opts->{branchcode},
categorycode => $opts->{categorycode},
item_type => $opts->{item_type},
@ -173,9 +167,6 @@ sub create {
}
}
=head3 C4::ItemCirculationAlertPreference->delete(\%opts)
Delete an item circulation alert preference. You can delete by either passing
@ -185,9 +176,9 @@ triplet.
=cut
sub delete {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
my $dbh = C4::Context->dbh;
if ($opts->{id}) {
if ( $opts->{id} ) {
$dbh->do(
"DELETE FROM item_circulation_alert_preferences WHERE id = ?",
{},
@ -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>
@ -237,7 +224,7 @@ B<Example>:
=cut
sub is_disabled_for {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
$valid->($opts);
my $dbh = C4::Context->dbh;
@ -265,13 +252,10 @@ sub is_disabled_for {
}
sub is_enabled_for {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
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
@ -287,7 +271,7 @@ B<Example>:
=cut
sub find {
my ($class, $where) = @_;
my ( $class, $where ) = @_;
my $dbh = C4::Context->dbh;
my $query = qq{
SELECT id, branchcode, categorycode, item_type, notification
@ -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>.
@ -328,21 +311,21 @@ See F<admin/item_circulation_alerts.pl> to see how this method is used.
=cut
sub grid {
my ($class, $where) = @_;
my ( $class, $where ) = @_;
my @branch_prefs = $class->find($where);
my @default_prefs = $class->find({ branchcode => '*', notification => $where->{notification} });
my @default_prefs = $class->find( { branchcode => '*', notification => $where->{notification} } );
my @cc = Koha::Patron::Categories->search_with_library_limits->as_list;
my @it = Koha::ItemTypes->search->as_list;
my $notification = $where->{notification};
my %disabled = map {
my $key = $_->categorycode . "-" . $_->item_type . "-" . $notification;
$key =~ s/\*/_/g;
($key => 1);
( $key => 1 );
} @branch_prefs;
my %default = map {
my $key = $_->categorycode . "-" . $_->item_type . "-" . $notification;
$key =~ s/\*/_/g;
($key => 1);
( $key => 1 );
} @default_prefs;
my @grid;
for my $c (@cc) {
@ -353,16 +336,16 @@ sub grid {
$key =~ s/\*/_/g;
my @classes;
my $text = " ";
if ($disabled{$key}) {
if ( $disabled{$key} ) {
push @classes, 'disabled';
$text = "Disabled for $where->{branchcode}";
}
if ($default{$key}) {
if ( $default{$key} ) {
push @classes, 'default';
$text = "Disabled for all";
}
push @{$row->{items}}, {
class => join(' ', @classes),
push @{ $row->{items} }, {
class => join( ' ', @classes ),
id => $key,
text => $text,
};
@ -371,9 +354,6 @@ sub grid {
return \@grid;
}
=head2 Object Methods
These are read-only accessors for the various attributes of a preference.
@ -402,7 +382,7 @@ sub AUTOLOAD {
my $self = shift;
my $attr = $AUTOLOAD;
$attr =~ s/.*://;
if (exists $self->{$attr}) {
if ( exists $self->{$attr} ) {
return $self->{$attr};
} else {
return;
@ -411,8 +391,6 @@ sub AUTOLOAD {
sub DESTROY { }
=head1 SEE ALSO
L<C4::Circulation>, F<admin/item_circulation_alerts.pl>

444
C4/Items.pm
View File

@ -20,7 +20,8 @@ package C4::Items;
use Modern::Perl;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -54,7 +55,8 @@ 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
# debugging; so please don't remove this
use Try::Tiny qw( catch try );
use Koha::AuthorisedValues;
@ -119,15 +121,15 @@ location is a special processing ('PROC') or shelving cart
=cut
sub CartToShelf {
my ( $itemnumber ) = @_;
my ($itemnumber) = @_;
unless ( $itemnumber ) {
unless ($itemnumber) {
croak "FAILED CartToShelf() - no itemnumber supplied";
}
my $item = Koha::Items->find($itemnumber);
if ( $item->location eq 'CART' ) {
$item->location($item->permanent_location)->store({ skip_holds_queue => 1 });
$item->location( $item->permanent_location )->store( { skip_holds_queue => 1 } );
}
}
@ -163,18 +165,18 @@ sub AddItemFromMarc {
# parse item hash from MARC
my $frameworkcode = C4::Biblio::GetFrameworkCode($biblionumber);
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField( "items.itemnumber" );
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField("items.itemnumber");
my $localitemmarc = MARC::Record->new;
$localitemmarc->append_fields( $source_item_marc->field($itemtag) );
my $item_values = C4::Biblio::TransformMarcToKoha({ record => $localitemmarc, limit_table => 'items' });
my $item_values = C4::Biblio::TransformMarcToKoha( { record => $localitemmarc, limit_table => 'items' } );
my $unlinked_item_subfields = _get_unlinked_item_subfields( $localitemmarc, $frameworkcode );
$item_values->{more_subfields_xml} = _get_unlinked_subfields_xml($unlinked_item_subfields);
$item_values->{biblionumber} = $biblionumber;
$item_values->{biblioitemnumber} = $params->{biblioitemnumber};
$item_values->{cn_source} = delete $item_values->{'items.cn_source'}; # Because of C4::Biblio::_disambiguate
$item_values->{cn_sort} = delete $item_values->{'items.cn_sort'}; # Because of C4::Biblio::_disambiguate
my $item = Koha::Item->new( $item_values )->store({ skip_record_index => $params->{skip_record_index} });
my $item = Koha::Item->new($item_values)->store( { skip_record_index => $params->{skip_record_index} } );
return ( $item->biblionumber, $item->biblioitemnumber, $item->itemnumber );
}
@ -224,7 +226,7 @@ Additional information appropriate to the error condition.
=cut
sub AddItemBatchFromMarc {
my ($record, $biblionumber, $biblioitemnumber, $frameworkcode) = @_;
my ( $record, $biblionumber, $biblioitemnumber, $frameworkcode ) = @_;
my @itemnumbers = ();
my @errors = ();
my $dbh = C4::Context->dbh;
@ -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 ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField("items.itemnumber");
my $item_sequence_num = 0;
ITEMFIELD: foreach my $item_field ($record->field($itemtag)) {
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
@ -246,8 +250,8 @@ sub AddItemBatchFromMarc {
$temp_item_marc->append_fields($item_field);
# add biblionumber and biblioitemnumber
my $item = TransformMarcToKoha({ record => $temp_item_marc, limit_table => 'items' });
my $unlinked_item_subfields = _get_unlinked_item_subfields($temp_item_marc, $frameworkcode);
my $item = TransformMarcToKoha( { record => $temp_item_marc, limit_table => 'items' } );
my $unlinked_item_subfields = _get_unlinked_item_subfields( $temp_item_marc, $frameworkcode );
$item->{'more_subfields_xml'} = _get_unlinked_subfields_xml($unlinked_item_subfields);
$item->{'biblionumber'} = $biblionumber;
$item->{'biblioitemnumber'} = $biblioitemnumber;
@ -257,7 +261,7 @@ sub AddItemBatchFromMarc {
# check for duplicate barcode
my %item_errors = CheckItemPreSave($item);
if (%item_errors) {
push @errors, _repack_item_errors($item_sequence_num, $item, \%item_errors);
push @errors, _repack_item_errors( $item_sequence_num, $item, \%item_errors );
push @bad_item_fields, $item_field;
next ITEMFIELD;
}
@ -265,10 +269,11 @@ 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));
my $new_item_marc = _marc_from_item_hash( $item_object->unblessed, $frameworkcode, $unlinked_item_subfields );
$item_field->replace_with( $new_item_marc->field($itemtag) );
}
# remove any MARC item fields for rejected items
@ -276,7 +281,7 @@ sub AddItemBatchFromMarc {
$record->delete_field($item_field);
}
return (\@itemnumbers, \@errors);
return ( \@itemnumbers, \@errors );
}
=head2 ModItemFromMarc
@ -298,24 +303,25 @@ sub ModItemFromMarc {
my ( $item_marc, $biblionumber, $itemnumber, $params ) = @_;
my $frameworkcode = C4::Biblio::GetFrameworkCode($biblionumber);
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField( "items.itemnumber" );
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField("items.itemnumber");
my $localitemmarc = MARC::Record->new;
$localitemmarc->append_fields( $item_marc->field($itemtag) );
my $item_object = Koha::Items->find($itemnumber);
my $item = TransformMarcToKoha({ record => $localitemmarc, limit_table => 'items' });
my $item = TransformMarcToKoha( { record => $localitemmarc, limit_table => 'items' } );
# When importing items we blank this column, we need to set it to the existing value
# to prevent it being blanked by set_or_blank
$item->{onloan} = $item_object->onloan if( $item_object->onloan && !defined $item->{onloan} );
$item->{onloan} = $item_object->onloan if ( $item_object->onloan && !defined $item->{onloan} );
# When importing and replacing items we should not remove the dateacquired so we should set it
# to the existing value
$item->{dateaccessioned} = $item_object->dateaccessioned
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 ( $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 );
# Retrieving the values for the fields that are not linked
my @mapped_fields = Koha::MarcSubfieldStructures->search(
@ -342,8 +348,8 @@ sub ModItemFromMarc {
$item_object->make_column_dirty('permanent_location') if $has_permanent_location;
my $unlinked_item_subfields = _get_unlinked_item_subfields( $localitemmarc, $frameworkcode );
$item_object->more_subfields_xml(_get_unlinked_subfields_xml($unlinked_item_subfields));
$item_object->store({ skip_record_index => $params->{skip_record_index} });
$item_object->more_subfields_xml( _get_unlinked_subfields_xml($unlinked_item_subfields) );
$item_object->store( { skip_record_index => $params->{skip_record_index} } );
return $item_object->unblessed;
}
@ -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
@ -509,17 +520,17 @@ sub CheckItemPreSave {
}
# check for valid home branch
if (exists $item_ref->{'homebranch'} and defined $item_ref->{'homebranch'}) {
if ( exists $item_ref->{'homebranch'} and defined $item_ref->{'homebranch'} ) {
my $home_library = Koha::Libraries->find( $item_ref->{homebranch} );
unless (defined $home_library) {
unless ( defined $home_library ) {
$errors{'invalid_homebranch'} = $item_ref->{'homebranch'};
}
}
# check for valid holding branch
if (exists $item_ref->{'holdingbranch'} and defined $item_ref->{'holdingbranch'}) {
if ( exists $item_ref->{'holdingbranch'} and defined $item_ref->{'holdingbranch'} ) {
my $holding_library = Koha::Libraries->find( $item_ref->{holdingbranch} );
unless (defined $holding_library) {
unless ( defined $holding_library ) {
$errors{'invalid_holdingbranch'} = $item_ref->{'holdingbranch'};
}
}
@ -568,7 +579,7 @@ $iTotalRecords is the number of rows that would have been returned without the $
=cut
sub GetItemsForInventory {
my ( $parameters ) = @_;
my ($parameters) = @_;
my $minlocation = $parameters->{'minlocation'} // '';
my $maxlocation = $parameters->{'maxlocation'} // '';
my $class_source = $parameters->{'class_source'} // C4::Context->preference('DefaultClassificationSource');
@ -588,8 +599,8 @@ sub GetItemsForInventory {
my $dbh = C4::Context->dbh;
my ( @bind_params, @where_strings );
my $min_cnsort = GetClassSort($class_source,undef,$minlocation);
my $max_cnsort = GetClassSort($class_source,undef,$maxlocation);
my $min_cnsort = GetClassSort( $class_source, undef, $minlocation );
my $max_cnsort = GetClassSort( $class_source, undef, $maxlocation );
my $select_columns = q{
SELECT DISTINCT(items.itemnumber), barcode, itemcallnumber, title, author, biblio.biblionumber, biblio.frameworkcode, datelastseen, homebranch, location, notforloan, damaged, itemlost, withdrawn, stocknumber, items.cn_sort, ccode
@ -601,16 +612,16 @@ sub GetItemsForInventory {
LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
LEFT JOIN biblioitems on items.biblionumber = biblioitems.biblionumber
};
if ($statushash){
for my $authvfield (keys %$statushash){
if ( scalar @{$statushash->{$authvfield}} > 0 ){
my $joinedvals = join ',', @{$statushash->{$authvfield}};
if ($statushash) {
for my $authvfield ( keys %$statushash ) {
if ( scalar @{ $statushash->{$authvfield} } > 0 ) {
my $joinedvals = join ',', @{ $statushash->{$authvfield} };
push @where_strings, "$authvfield in (" . $joinedvals . ")";
}
}
}
if ($ccode){
if ($ccode) {
push @where_strings, 'ccode = ?';
push @bind_params, $ccode;
}
@ -630,85 +641,93 @@ sub GetItemsForInventory {
push @bind_params, $datelastseen;
}
if ( $location ) {
if ($location) {
push @where_strings, 'items.location = ?';
push @bind_params, $location;
}
if ( $branchcode ) {
if($branch eq "homebranch"){
if ($branchcode) {
if ( $branch eq "homebranch" ) {
push @where_strings, 'items.homebranch = ?';
}else{
} else {
push @where_strings, 'items.holdingbranch = ?';
}
push @bind_params, $branchcode;
}
if ( $itemtype ) {
if ($itemtype) {
push @where_strings, 'biblioitems.itemtype = ?';
push @bind_params, $itemtype;
}
if ( $ignoreissued) {
if ($ignoreissued) {
$query .= "LEFT JOIN issues ON items.itemnumber = issues.itemnumber ";
push @where_strings, 'issues.date_due IS NULL';
}
if ( $ignore_waiting_holds ) {
if ($ignore_waiting_holds) {
$query .= "LEFT JOIN reserves ON items.itemnumber = reserves.itemnumber ";
push( @where_strings, q{(reserves.found != 'W' OR reserves.found IS NULL)} );
}
if ( @$itemtypes ) {
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 ) {
if (@where_strings) {
$query .= 'WHERE ';
$query .= join ' AND ', @where_strings;
}
my $count_query = $select_count . $query;
$query .= ' ORDER BY items.cn_sort, itemcallnumber, title';
$query .= " LIMIT $offset, $size" if ($offset and $size);
$query .= " LIMIT $offset, $size" if ( $offset and $size );
$query = $select_columns . $query;
my $sth = $dbh->prepare($query);
$sth->execute( @bind_params );
$sth->execute(@bind_params);
my @results = ();
my $tmpresults = $sth->fetchall_arrayref({});
$sth = $dbh->prepare( $count_query );
$sth->execute( @bind_params );
my $tmpresults = $sth->fetchall_arrayref( {} );
$sth = $dbh->prepare($count_query);
$sth->execute(@bind_params);
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{} ) }
)
) {
$row->{$_} = $avmapping->{"items.$_,".$row->{'frameworkcode'}.",".$row->{$_}};
foreach ( keys %$row ) {
if ( defined( $avmapping->{ "items.$_," . $row->{'frameworkcode'} . "," . ( $row->{$_} // q{} ) } ) ) {
$row->{$_} = $avmapping->{ "items.$_," . $row->{'frameworkcode'} . "," . $row->{$_} };
}
}
push @results, $row;
}
return (\@results, $iTotalRecords);
return ( \@results, $iTotalRecords );
}
=head2 get_hostitemnumbers_of
@ -722,11 +741,10 @@ references on array of itemnumbers.
=cut
sub get_hostitemnumbers_of {
my ($biblionumber) = @_;
if( !C4::Context->preference('EasyAnalyticalRecords') ) {
if ( !C4::Context->preference('EasyAnalyticalRecords') ) {
return ();
}
@ -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';
@ -752,11 +769,12 @@ sub get_hostitemnumbers_of {
my $hostbiblionumber = $hostfield->subfield($biblio_s);
next unless $hostbiblionumber; # have tag, don't have $biblio_s subfield
my $linkeditemnumber = $hostfield->subfield($item_s);
if ( ! $linkeditemnumber ) {
if ( !$linkeditemnumber ) {
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;
}
@ -805,23 +823,23 @@ sub GetMarcItem {
# Tack on 'items.' prefix to column names so that C4::Biblio::TransformKohaToMarc will work.
# Also, don't emit a subfield if the underlying field is blank.
return Item2Marc($item->unblessed, $biblionumber);
return Item2Marc( $item->unblessed, $biblionumber );
}
sub Item2Marc {
my ($itemrecord,$biblionumber)=@_;
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 $framework = C4::Biblio::GetFrameworkCode($biblionumber);
my $itemmarc = C4::Biblio::TransformKohaToMarc( $mungeditem, { framework => $framework } );
my ( $itemtag, $itemsubfield ) = C4::Biblio::GetMarcFromKohaField('items.itemnumber');
my $unlinked_item_subfields = _parse_unlinked_item_subfields_from_xml($mungeditem->{'items.more_subfields_xml'});
if (defined $unlinked_item_subfields and $#$unlinked_item_subfields > -1) {
foreach my $field ($itemmarc->field($itemtag)){
my $unlinked_item_subfields = _parse_unlinked_item_subfields_from_xml( $mungeditem->{'items.more_subfields_xml'} );
if ( defined $unlinked_item_subfields and $#$unlinked_item_subfields > -1 ) {
foreach my $field ( $itemmarc->field($itemtag) ) {
$field->add_subfields(@$unlinked_item_subfields);
}
}
@ -861,21 +879,28 @@ 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} ) {
my ( $tag, $subfield ) = C4::Biblio::GetMarcFromKohaField( $item_field );
my ( $tag, $subfield ) = C4::Biblio::GetMarcFromKohaField($item_field);
next unless defined $tag and defined $subfield; # skip if not mapped to MARC field
my @values = split(/\s?\|\s?/, $mungeditem->{$item_field}, -1);
foreach my $value (@values){
my @values = split( /\s?\|\s?/, $mungeditem->{$item_field}, -1 );
foreach my $value (@values) {
if ( my $field = $item_marc->field($tag) ) {
$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 );
@ -900,10 +925,10 @@ sub _repack_item_errors {
my @repacked_errors = ();
foreach my $error_code (sort keys %{ $error_ref }) {
foreach my $error_code ( sort keys %{$error_ref} ) {
my $repacked_error = {};
$repacked_error->{'item_sequence'} = $item_sequence_num;
$repacked_error->{'item_barcode'} = exists($item_ref->{'barcode'}) ? $item_ref->{'barcode'} : '';
$repacked_error->{'item_barcode'} = exists( $item_ref->{'barcode'} ) ? $item_ref->{'barcode'} : '';
$repacked_error->{'error_code'} = $error_code;
$repacked_error->{'error_information'} = $error_ref->{$error_code};
push @repacked_errors, $repacked_error;
@ -922,19 +947,20 @@ sub _get_unlinked_item_subfields {
my $original_item_marc = shift;
my $frameworkcode = shift;
my $marcstructure = C4::Biblio::GetMarcStructure(1, $frameworkcode, { unsafe => 1 });
my $marcstructure = C4::Biblio::GetMarcStructure( 1, $frameworkcode, { unsafe => 1 } );
# assume that this record has only one field, and that that
# field contains only the item information
my $subfields = [];
my @fields = $original_item_marc->fields();
if ($#fields > -1) {
if ( $#fields > -1 ) {
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'}) {
foreach my $subfield ( $field->subfields() ) {
if ( defined $subfield->[1]
and $subfield->[1] ne ''
and !$marcstructure->{$tag}->{ $subfield->[0] }->{'kohafield'} )
{
push @$subfields, $subfield->[0] => $subfield->[1];
}
}
@ -952,11 +978,15 @@ 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));
$marc->append_fields( MARC::Field->new( '999', ' ', ' ', @$unlinked_item_subfields ) );
$marc->encoding("UTF-8");
$xml = $marc->as_xml("USMARC");
}
@ -974,11 +1004,11 @@ sub _parse_unlinked_item_subfields_from_xml {
my $xml = shift;
require C4::Charset;
return unless defined $xml and $xml ne "";
my $marc = MARC::Record->new_from_xml(C4::Charset::StripNonXmlChars($xml),'UTF-8');
my $marc = MARC::Record->new_from_xml( C4::Charset::StripNonXmlChars($xml), 'UTF-8' );
my $unlinked_subfields = [];
my @fields = $marc->fields();
if ($#fields > -1) {
foreach my $subfield ($fields[0]->subfields()) {
if ( $#fields > -1 ) {
foreach my $subfield ( $fields[0]->subfields() ) {
push @$unlinked_subfields, $subfield->[0] => $subfield->[1];
}
}
@ -1002,9 +1032,9 @@ sub GetAnalyticsCount {
### ZOOM search here
my $query;
$query= "hi=".$itemnumber;
my $searcher = Koha::SearchEngine::Search->new({index => $Koha::SearchEngine::BIBLIOS_INDEX});
my ($err,$res,$result) = $searcher->simple_search_compat($query,0,10);
$query = "hi=" . $itemnumber;
my $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::BIBLIOS_INDEX } );
my ( $err, $res, $result ) = $searcher->simple_search_compat( $query, 0, 10 );
return ($result);
}
@ -1014,9 +1044,9 @@ sub _SearchItems_build_where_fragment {
my $dbh = C4::Context->dbh;
my $where_fragment;
if (exists($filter->{conjunction})) {
my (@where_strs, @where_args);
foreach my $f (@{ $filter->{filters} }) {
if ( exists( $filter->{conjunction} ) ) {
my ( @where_strs, @where_args );
foreach my $f ( @{ $filter->{filters} } ) {
my $fragment = _SearchItems_build_where_fragment($f);
if ($fragment) {
push @where_strs, $fragment->{str};
@ -1025,7 +1055,7 @@ sub _SearchItems_build_where_fragment {
}
my $where_str = '';
if (@where_strs) {
$where_str = '(' . join (' ' . $filter->{conjunction} . ' ', @where_strs) . ')';
$where_str = '(' . join( ' ' . $filter->{conjunction} . ' ', @where_strs ) . ')';
$where_fragment = {
str => $where_str,
args => \@where_args,
@ -1039,39 +1069,42 @@ sub _SearchItems_build_where_fragment {
my @operators = qw(= != > < >= <= is like);
push @operators, 'not like';
my $field = $filter->{field} // q{};
if ( (0 < grep { $_ eq $field } @columns) or (substr($field, 0, 5) eq 'marc:') ) {
if ( ( 0 < grep { $_ eq $field } @columns ) or ( substr( $field, 0, 5 ) eq 'marc:' ) ) {
my $op = $filter->{operator};
my $query = $filter->{query};
my $ifnull = $filter->{ifnull};
if (!$op or (0 == grep { $_ eq $op } @operators)) {
if ( !$op or ( 0 == grep { $_ eq $op } @operators ) ) {
$op = '='; # default operator
}
my $column;
if ($field =~ /^marc:(\d{3})(?:\$(\w))?$/) {
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.
my $xpath;
my $sqlfield;
my ($itemfield) = C4::Biblio::GetMarcFromKohaField('items.itemnumber');
if ($marcfield eq $itemfield) {
if ( $marcfield eq $itemfield ) {
$sqlfield = 'more_subfields_xml';
$xpath = '//record/datafield/subfield[@code="' . $marcsubfield . '"]';
} else {
$sqlfield = 'metadata'; # From biblio_metadata
if ($marcfield < 10) {
if ( $marcfield < 10 ) {
$xpath = "//record/controlfield[\@tag=\"$marcfield\"]";
} else {
$xpath = "//record/datafield[\@tag=\"$marcfield\"]/subfield[\@code=\"$marcsubfield\"]";
@ -1079,18 +1112,16 @@ 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 );
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 );
my @issns = C4::Koha::GetVariationsOfISSN($query);
$query = [];
push @$query, @issns;
}
@ -1103,21 +1134,20 @@ sub _SearchItems_build_where_fragment {
$column = "COALESCE($column, ?)";
}
if (ref $query eq 'ARRAY') {
if ($op eq 'like') {
if ( ref $query eq 'ARRAY' ) {
if ( $op eq 'like' ) {
$where_fragment = {
str => "($column LIKE " . join (" OR $column LIKE ", ('?') x @$query ) . ")",
str => "($column LIKE " . join( " OR $column LIKE ", ('?') x @$query ) . ")",
args => $query,
};
}
else {
if ($op eq '=') {
} else {
if ( $op eq '=' ) {
$op = 'IN';
} elsif ($op eq '!=') {
} elsif ( $op eq '!=' ) {
$op = 'NOT IN';
}
$where_fragment = {
str => "$column $op (" . join (',', ('?') x @$query) . ")",
str => "$column $op (" . join( ',', ('?') x @$query ) . ")",
args => $query,
};
}
@ -1129,7 +1159,7 @@ sub _SearchItems_build_where_fragment {
} else {
$where_fragment = {
str => "$column $op ?",
args => [ $query ],
args => [$query],
};
}
@ -1190,7 +1220,7 @@ $params is a reference to a hash that can contain the following parameters:
=cut
sub SearchItems {
my ($filter, $params) = @_;
my ( $filter, $params ) = @_;
$filter //= {};
$params //= {};
@ -1203,7 +1233,7 @@ sub SearchItems {
$params->{sortby} ||= 'itemnumber';
$params->{sortorder} ||= 'ASC';
my ($where_str, @where_args);
my ( $where_str, @where_args );
my $where_fragment = _SearchItems_build_where_fragment($filter);
if ($where_fragment) {
$where_str = $where_fragment->{str};
@ -1220,7 +1250,7 @@ sub SearchItems {
LEFT JOIN issues USING (itemnumber)
WHERE 1
};
if (defined $where_str and $where_str ne '') {
if ( defined $where_str and $where_str ne '' ) {
$query .= qq{ AND $where_str };
}
@ -1233,34 +1263,32 @@ sub SearchItems {
push @columns, Koha::Database->new()->schema()->resultset('Issue')->result_source->columns;
if ( $params->{sortby} eq 'availability' ) {
my $sortorder = (uc($params->{sortorder}) eq 'ASC') ? 'ASC' : 'DESC';
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';
my $sortorder = ( uc( $params->{sortorder} ) eq 'ASC' ) ? 'ASC' : 'DESC';
$query .= qq{ ORDER BY $sortby $sortorder };
}
my $rows = $params->{rows};
my @limit_args;
if ($rows > 0) {
my $offset = $rows * ($params->{page}-1);
if ( $rows > 0 ) {
my $offset = $rows * ( $params->{page} - 1 );
$query .= qq { LIMIT ?, ? };
push @limit_args, $offset, $rows;
}
my $sth = $dbh->prepare($query);
my $rv = $sth->execute(@where_args, @limit_args);
my $rv = $sth->execute( @where_args, @limit_args );
return unless ($rv);
my ($total_rows) = $dbh->selectrow_array(q{ SELECT FOUND_ROWS() });
return ($sth->fetchall_arrayref({}), $total_rows);
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);
@ -1321,7 +1348,7 @@ sub PrepareItemrecordDisplay {
my $dbh = C4::Context->dbh;
$frameworkcode = C4::Biblio::GetFrameworkCode($bibnum) if $bibnum;
my ( $itemtagfield, $itemtagsubfield ) = C4::Biblio::GetMarcFromKohaField( "items.itemnumber" );
my ( $itemtagfield, $itemtagsubfield ) = C4::Biblio::GetMarcFromKohaField("items.itemnumber");
# Note: $tagslib obtained from GetMarcStructure() in 'unsafe' mode is
# a shared data structure. No plugin (including custom ones) should change
@ -1354,7 +1381,8 @@ 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 );
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" );
@ -1372,7 +1401,7 @@ sub PrepareItemrecordDisplay {
$subfield_data{subfield} = $subfield->{subfield};
$subfield_data{countsubfield} = $cntsubf++;
$subfield_data{kohafield} = $subfield->{kohafield};
$subfield_data{id} = "tag_".$tag."_subfield_".$subfield->{subfield}."_".int(rand(1000000));
$subfield_data{id} = "tag_" . $tag . "_subfield_" . $subfield->{subfield} . "_" . int( rand(1000000) );
# $subfield_data{marc_lib}=$tagslib->{$tag}->{$subfield}->{lib};
$subfield_data{marc_lib} = $subfield->{lib};
@ -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,51 +1444,62 @@ sub PrepareItemrecordDisplay {
# search for itemcallnumber if applicable
if ( $subfield->{kohafield} eq 'items.itemcallnumber'
&& C4::Context->preference('itemcallnumber') && $itemrecord) {
foreach my $itemcn_pref (split(/,/,C4::Context->preference('itemcallnumber'))){
&& 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);
my $CNsubfields = substr( $itemcn_pref, 3 );
$CNsubfields = undef if $CNsubfields eq '';
$defaultvalue = $field->as_string( $CNsubfields, ' ');
$defaultvalue = $field->as_string( $CNsubfields, ' ' );
last if $defaultvalue;
}
}
if ( $subfield->{kohafield} eq 'items.itemcallnumber'
&& $defaultvalues
&& $defaultvalues->{'callnumber'} ) {
if( $itemrecord and $defaultvalues and not $itemrecord->subfield($tag,$subfield->{subfield}) ){
&& $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'} ) {
if ( $itemrecord and $defaultvalues and not $itemrecord->subfield($tag,$subfield) ) {
&& $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 ( $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} );
@ -1480,7 +1524,7 @@ sub PrepareItemrecordDisplay {
$authorised_lib{$branchcode} = $branchname;
}
} else {
my $sth = $dbh->prepare( "SELECT branchcode,branchname FROM branches ORDER BY branchname" );
my $sth = $dbh->prepare("SELECT branchcode,branchname FROM branches ORDER BY branchname");
$sth->execute;
push @authorised_values, ""
unless ( $subfield->{mandatory} );
@ -1501,9 +1545,9 @@ sub PrepareItemrecordDisplay {
push @authorised_values, "";
while ( my $itemtype = $itemtypes->next ) {
push @authorised_values, $itemtype->itemtype;
$authorised_lib{$itemtype->itemtype} = $itemtype->translated_description;
$authorised_lib{ $itemtype->itemtype } = $itemtype->translated_description;
}
if ($defaultvalues && $defaultvalues->{'itemtype'}) {
if ( $defaultvalues && $defaultvalues->{'itemtype'} ) {
$defaultvalue = $defaultvalues->{'itemtype'};
}
@ -1514,9 +1558,10 @@ sub PrepareItemrecordDisplay {
my $class_sources = GetClassSources();
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);
foreach my $class_source ( sort keys %$class_sources ) {
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 ) {
);
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;
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;
} 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 );
}

200
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;
@ -31,7 +30,8 @@ use Business::ISBN;
use Business::ISSN;
use autouse 'Data::cselectall_arrayref' => qw(Dumper);
our (@ISA, @EXPORT_OK);
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|
@ -110,7 +111,7 @@ sub GetItemTypesCategorized {
LEFT JOIN authorised_values ON searchcategory = authorised_value
WHERE searchcategory > '' and hideinopac=0
|;
return ($dbh->selectall_hashref($query,'itemtype'));
return ( $dbh->selectall_hashref( $query, 'itemtype' ) );
}
=head2 getitemtypeimagedir
@ -125,8 +126,8 @@ returns the full path to the appropriate directory containing images.
sub getitemtypeimagedir {
my $src = shift || 'opac';
if ($src eq 'intranet') {
return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
if ( $src eq 'intranet' ) {
return C4::Context->config('intrahtdocs') . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
} else {
return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
}
@ -134,7 +135,7 @@ sub getitemtypeimagedir {
sub getitemtypeimagesrc {
my $src = shift || 'opac';
if ($src eq 'intranet') {
if ( $src eq 'intranet' ) {
return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
} else {
return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
@ -147,11 +148,11 @@ sub getitemtypeimagelocation {
return '' if ( !$image );
require URI::Split;
my $scheme = ( URI::Split::uri_split( $image ) )[0];
my $scheme = ( URI::Split::uri_split($image) )[0];
return $image if ( $scheme );
return $image if ($scheme);
return getitemtypeimagesrc( $src ) . '/' . $image;
return getitemtypeimagesrc($src) . '/' . $image;
}
=head3 _getImagesFromDirectory
@ -174,8 +175,8 @@ sub _getImagesFromDirectory {
return unless defined $directoryname;
return unless -d $directoryname;
if ( opendir ( my $dh, $directoryname ) ) {
my @images = grep { /\.(gif|png)$/i } readdir( $dh );
if ( opendir( my $dh, $directoryname ) ) {
my @images = grep { /\.(gif|png)$/i } readdir($dh);
closedir $dh;
@images = sort(@images);
return @images;
@ -204,8 +205,8 @@ sub _getSubdirectoryNames {
return unless defined $directoryname;
return unless -d $directoryname;
if ( opendir ( my $dh, $directoryname ) ) {
my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
if ( opendir( my $dh, $directoryname ) ) {
my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && !(/^\./) } readdir($dh);
closedir $dh;
return @directories;
} else {
@ -237,23 +238,29 @@ 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'),
}
};
my @imagesets = (); # list of hasrefs of image set data to pass to template
my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
foreach my $imagesubdir ( @subdirectories ) {
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",
foreach my $thisimage (@imagenames) {
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;
@ -319,41 +327,40 @@ sub getFacets {
{
idx => 'su-to',
label => 'Topics',
tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
tags => [qw/ 600ab 601ab 602a 604at 605a 606ax 610a /],
sep => ' - ',
},
{
idx => 'su-geo',
label => 'Places',
tags => [ qw/ 607a / ],
tags => [qw/ 607a /],
sep => ' - ',
},
{
idx => 'au',
label => 'Authors',
tags => [ qw/ 700ab 701ab 702ab / ],
tags => [qw/ 700ab 701ab 702ab /],
sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
},
{
idx => 'se',
label => 'Series',
tags => [ qw/ 225a / ],
tags => [qw/ 225a /],
sep => ', ',
},
{
idx => 'location',
label => 'Location',
tags => [ qw/ 995e / ],
tags => [qw/ 995e /],
},
{
idx => 'ccode',
label => 'Collections',
tags => [ qw / 099t 955h / ],
tags => [qw / 099t 955h /],
}
];
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,15 +388,15 @@ sub getFacets {
);
}
}
}
else {
} else {
$facets = [
{
idx => 'su-to',
label => 'Topics',
tags => [ qw/ 650a / ],
tags => [qw/ 650a /],
sep => '--',
},
# {
# idx => 'su-na',
# label => 'People and Organizations',
@ -399,47 +406,46 @@ sub getFacets {
{
idx => 'su-geo',
label => 'Places',
tags => [ qw/ 651a / ],
tags => [qw/ 651a /],
sep => '--',
},
{
idx => 'su-ut',
label => 'Titles',
tags => [ qw/ 630a / ],
tags => [qw/ 630a /],
sep => '--',
},
{
idx => 'au',
label => 'Authors',
tags => [ qw/ 100a 110a 700a / ],
tags => [qw/ 100a 110a 700a /],
sep => ', ',
},
{
idx => 'se',
label => 'Series',
tags => [ qw/ 440a 490a / ],
tags => [qw/ 440a 490a /],
sep => ', ',
},
{
idx => 'itype',
label => 'Item types',
tags => [ qw/ 952y 942c / ],
tags => [qw/ 952y 942c /],
sep => ', ',
},
{
idx => 'location',
label => 'Location',
tags => [ qw / 952c / ],
tags => [qw / 952c /],
},
{
idx => 'ccode',
label => 'Collections',
tags => [ qw / 9528 / ],
tags => [qw / 9528 /],
}
];
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,27 +511,30 @@ sub GetAuthorisedValues {
} if $branch_limit;
my @where_strings;
my @where_args;
if($category) {
if ($category) {
push @where_strings, "category = ?";
push @where_args, $category;
}
if($branch_limit) {
if ($branch_limit) {
push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
push @where_args, $branch_limit;
}
if(@where_strings > 0) {
$query .= " WHERE " . join(" AND ", @where_strings);
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'
);
my $sth = $dbh->prepare($query);
$sth->execute( @where_args );
while (my $data=$sth->fetchrow_hashref) {
if ($opac && $data->{lib_opac}) {
$sth->execute(@where_args);
while ( my $data = $sth->fetchrow_hashref ) {
if ( $opac && $data->{lib_opac} ) {
$data->{lib} = $data->{lib_opac};
}
push @results, $data;
@ -571,7 +578,7 @@ MARC field, replacing any blanks with '#'.
sub display_marc_indicators {
my $field = shift;
my $indicators = '';
if ($field && $field->tag() >= 10) {
if ( $field && $field->tag() >= 10 ) {
$indicators = $field->indicator(1) . $field->indicator(2);
$indicators =~ s/ /#/g;
}
@ -579,27 +586,26 @@ sub display_marc_indicators {
}
sub GetNormalizedUPC {
my ($marcrecord,$marcflavour) = @_;
my ( $marcrecord, $marcflavour ) = @_;
$marcflavour ||= C4::Context->preference('marcflavour');
return unless $marcrecord;
if ($marcflavour eq 'UNIMARC') {
if ( $marcflavour eq 'UNIMARC' ) {
my @fields = $marcrecord->field('072');
foreach my $field (@fields) {
my $upc = _normalize_match_point($field->subfield('a'));
my $upc = _normalize_match_point( $field->subfield('a') );
if ($upc) {
return $upc;
}
}
}
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);
my $upc = _normalize_match_point($field->subfield('a'));
if ($upc && $indicator eq '1' ) {
my $upc = _normalize_match_point( $field->subfield('a') );
if ( $upc && $indicator eq '1' ) {
return $upc;
}
}
@ -609,17 +615,18 @@ sub GetNormalizedUPC {
# Normalizes and returns the first valid ISBN found in the record
# ISBN13 are converted into ISBN10. This is required to get some book cover images.
sub GetNormalizedISBN {
my ($isbn,$marcrecord,$marcflavour) = @_;
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 );
($isbn) = split( /\|/, $isbn );
return _isbn_cleanup($isbn);
}
return unless $marcrecord;
if ($marcflavour eq 'UNIMARC') {
if ( $marcflavour eq 'UNIMARC' ) {
my @fields = $marcrecord->field('010');
foreach my $field (@fields) {
my $isbn = $field->subfield('a');
@ -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');
@ -640,24 +646,23 @@ sub GetNormalizedISBN {
}
sub GetNormalizedEAN {
my ($marcrecord,$marcflavour) = @_;
my ( $marcrecord, $marcflavour ) = @_;
return unless $marcrecord;
if ($marcflavour eq 'UNIMARC') {
if ( $marcflavour eq 'UNIMARC' ) {
my @fields = $marcrecord->field('073');
foreach my $field (@fields) {
my $ean = _normalize_match_point($field->subfield('a'));
if ( $ean ) {
my $ean = _normalize_match_point( $field->subfield('a') );
if ($ean) {
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);
my $ean = _normalize_match_point($field->subfield('a'));
my $ean = _normalize_match_point( $field->subfield('a') );
if ( $ean && $indicator eq '3' ) {
return $ean;
}
@ -666,28 +671,29 @@ sub GetNormalizedEAN {
}
sub GetNormalizedOCLCNumber {
my ($marcrecord,$marcflavour) = @_;
my ( $marcrecord, $marcflavour ) = @_;
return unless $marcrecord;
$marcflavour ||= C4::Context->preference('marcflavour');
if ($marcflavour ne 'UNIMARC' ) {
if ( $marcflavour ne 'UNIMARC' ) {
my @fields = $marcrecord->field('035');
foreach my $field (@fields) {
my $oclc = $field->subfield('a');
if ($oclc && $oclc =~ /OCoLC/) {
if ( $oclc && $oclc =~ /OCoLC/ ) {
$oclc =~ s/\(OCoLC\)//;
return $oclc;
}
}
} else {
# TODO for UNIMARC
}
}
sub _normalize_match_point {
my $match_point = shift;
(my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
( my $normalized_match_point ) = $match_point =~ /([\d-]*[X]*)/;
$normalized_match_point =~ s/-//g;
return $normalized_match_point;
@ -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;
@ -752,7 +757,7 @@ sub NormalizeISBN {
}
return $string;
} elsif ( $return_invalid ) {
} elsif ($return_invalid) {
return $string;
}
@ -778,11 +783,11 @@ sub GetVariationsOfISBN {
my @isbns;
push( @isbns, NormalizeISBN({ isbn => $isbn, return_invalid => 1 }) );
push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
push( @isbns, NormalizeISBN( { isbn => $isbn, return_invalid => 1 } ) );
push( @isbns, NormalizeISBN( { isbn => $isbn, format => 'ISBN-10' } ) );
push( @isbns, NormalizeISBN( { isbn => $isbn, format => 'ISBN-13' } ) );
push( @isbns, NormalizeISBN( { isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 } ) );
push( @isbns, NormalizeISBN( { isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 } ) );
# Strip out any "empty" strings from the array
@isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
@ -806,7 +811,7 @@ sub GetVariationsOfISBN {
sub GetVariationsOfISBNs {
my (@isbns) = @_;
@isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
@isbns = map { GetVariationsOfISBN($_) } @isbns;
return wantarray ? @isbns : join( " | ", @isbns );
}
@ -834,12 +839,11 @@ sub NormalizeISSN {
my $issn = Business::ISSN->new($string);
if ( $issn && $issn->is_valid ){
if ( $issn && $issn->is_valid ) {
if ($strip_hyphen) {
$string = $issn->_issn;
}
else {
} else {
$string = $issn->as_string;
}
return $string;
@ -860,15 +864,15 @@ sub NormalizeISSN {
=cut
sub GetVariationsOfISSN {
my ( $issn ) = @_;
my ($issn) = @_;
return unless $issn;
my @issns;
my $str = NormalizeISSN({ issn => $issn });
if( $str ) {
my $str = NormalizeISSN( { issn => $issn } );
if ($str) {
push @issns, $str;
push @issns, NormalizeISSN({ issn => $issn, strip_hyphen => 1 });
push @issns, NormalizeISSN( { issn => $issn, strip_hyphen => 1 } );
} else {
push @issns, $issn;
}
@ -894,7 +898,7 @@ sub GetVariationsOfISSN {
sub GetVariationsOfISSNs {
my (@issns) = @_;
@issns = map { GetVariationsOfISSN( $_ ) } @issns;
@issns = map { GetVariationsOfISSN($_) } @issns;
return wantarray ? @issns : join( " | ", @issns );
}

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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?
}

322
C4/Labels/Label.pm
View File

@ -45,18 +45,17 @@ sub _check_params {
'text_wrap_cols',
'barcode',
);
if (scalar(@_) >1) {
if ( scalar(@_) > 1 ) {
$given_params = {@_};
foreach my $key (keys %{$given_params}) {
if (!(grep m/$key/, @valid_label_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $key);
foreach my $key ( keys %{$given_params} ) {
if ( !( grep m/$key/, @valid_label_params ) ) {
warn sprintf( 'Unrecognized parameter type of "%s".', $key );
$exit_code = 1;
}
}
}
else {
if (!(grep m/$_/, @valid_label_params)) {
warn sprintf('Unrecognized parameter type of "%s".', $_);
} 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,34 +82,47 @@ 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;");
# 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;"
);
$sth->execute($item_number);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
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'});
if ($sth1->err) {
warn sprintf('Database returned the following error: %s', $sth1->errstr);
$sth1->execute( $data->{'itemtype'} );
if ( $sth1->err ) {
warn sprintf( 'Database returned the following error: %s', $sth1->errstr );
}
my $data1 = $sth1->fetchrow_hashref;
$data->{'itemtype'} = $data1->{'description'};
$data->{'itype'} = $data1->{'description'};
# add *_description fields
if ($data->{'homebranch'} || $data->{'holdingbranch'}){
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;
}
@ -117,11 +131,11 @@ sub _get_text_fields {
my $format_string = shift;
my $csv = Text::CSV_XS->new( { allow_whitespace => 1, formula => "empty" } );
my $status = $csv->parse($format_string);
my @sorted_fields = map {{ 'code' => $_, desc => $_ }}
my @sorted_fields = map { { 'code' => $_, desc => $_ } }
map { $_ && $_ eq 'callnumber' ? 'itemcallnumber' : $_ } # see bug 5653
$csv->fields();
my $error = $csv->error_input();
warn sprintf('Text field sort failed with this error: %s', $error) if $error;
warn sprintf( 'Text field sort failed with this error: %s', $error ) if $error;
return \@sorted_fields;
}
@ -138,60 +152,56 @@ sub _get_barcode_data {
@{ $kohatables->{'branches'} }
)
);
FIELD_LIST:
FIELD_LIST:
while ($f) {
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 ) {
if ($item->{$field}) {
for my $field (@fields) {
if ( $item->{$field} ) {
push @data, $item->{$field};
}
}
$datastring .= join ' ', @data;
$f = $';
next FIELD_LIST;
}
elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
my ($field,$subf,$ws) = ($1,$2,$3);
my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField( "items.itemnumber" );
} 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);
if(@marcfield) {
if($field eq $itemtag) { # item-level data, we need to get the right item.
if (@marcfield) {
if ( $field eq $itemtag ) { # item-level data, we need to get the right item.
ITEM_FIELDS:
foreach my $itemfield (@marcfield) {
if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
if ($itemfield->subfield($subf)) {
if ( $itemfield->subfield($subf) ) {
$datastring .= $itemfield->subfield($subf) . $ws;
}
else {
warn sprintf("The '%s' field contains no data.", $f);
} else {
warn sprintf( "The '%s' field contains no data.", $f );
}
last ITEM_FIELDS;
}
}
} else { # bib-level data, we'll take the first matching tag/subfield.
if ($marcfield[0]->subfield($subf)) {
if ( $marcfield[0]->subfield($subf) ) {
$datastring .= $marcfield[0]->subfield($subf) . $ws;
}
else {
warn sprintf("The '%s' field contains no data.", $f);
} else {
warn sprintf( "The '%s' field contains no data.", $f );
}
}
}
$f = $';
next FIELD_LIST;
}
else {
warn sprintf('Failed to parse label format string: %s', $f);
} else {
warn sprintf( 'Failed to parse label format string: %s', $f );
last FIELD_LIST; # Failed to match
}
}
@ -201,10 +211,10 @@ sub _get_barcode_data {
sub _desc_koha_tables {
my $dbh = C4::Context->dbh();
my $kohatables;
for my $table ( 'biblio','biblioitems','items','branches' ) {
my $sth = $dbh->column_info(undef,undef,$table,'%');
while (my $info = $sth->fetchrow_hashref()){
push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
for my $table ( 'biblio', 'biblioitems', 'items', 'branches' ) {
my $sth = $dbh->column_info( undef, undef, $table, '%' );
while ( my $info = $sth->fetchrow_hashref() ) {
push @{ $kohatables->{$table} }, $info->{'COLUMN_NAME'};
}
$sth->finish;
}
@ -218,8 +228,9 @@ 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 $text_lly = ($self->{'lly'} + ($self->{'height'} - $self->{'top_text_margin'}));
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;
}
@ -284,7 +295,7 @@ sub _BARBIB {
}
sub new {
my ($invocant, %params) = @_;
my ( $invocant, %params ) = @_;
my $type = ref($invocant) || $invocant;
my $self = {
batch_id => $params{'batch_id'},
@ -310,10 +321,10 @@ sub new {
barcode => $params{'barcode'},
};
if ($self->{'guidebox'}) {
$self->{'guidebox'} = _guide_box($self->{'llx'}, $self->{'lly'}, $self->{'width'}, $self->{'height'});
if ( $self->{'guidebox'} ) {
$self->{'guidebox'} = _guide_box( $self->{'llx'}, $self->{'lly'}, $self->{'width'}, $self->{'height'} );
}
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -324,14 +335,13 @@ sub get_label_type {
sub get_attr {
my $self = shift;
if (_check_params(@_) eq 1) {
if ( _check_params(@_) eq 1 ) {
return -1;
}
my ($attr) = @_;
if (exists($self->{$attr})) {
if ( exists( $self->{$attr} ) ) {
return $self->{$attr};
}
else {
} else {
return -1;
}
return;
@ -340,20 +350,23 @@ sub get_attr {
sub create_label {
my $self = shift;
my $label_text = '';
my ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor);
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
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
}
if ($self->{'printing_type'} =~ /BIB/) {
$label_text = draw_label_text( $self,
if ( $self->{'printing_type'} =~ /BIB/ ) {
$label_text = draw_label_text(
$self,
llx => $text_llx,
lly => $text_lly,
line_spacer => $line_spacer,
);
}
if ($self->{'printing_type'} =~ /BAR/) {
barcode( $self,
if ( $self->{'printing_type'} =~ /BAR/ ) {
barcode(
$self,
llx => $barcode_llx,
lly => $barcode_lly,
width => $barcode_width,
@ -365,43 +378,44 @@ sub create_label {
}
sub draw_label_text {
my ($self, %params) = @_;
my ( $self, %params ) = @_;
my @label_text = ();
my $text_llx = 0;
my $text_lly = $params{'lly'};
my $font = $self->{'font'};
my $item = _get_label_item($self->{'item_number'});
my $label_fields = _get_text_fields($self->{'format_string'});
my $biblio = Koha::Biblios->find($item->{biblionumber});
my $item = _get_label_item( $self->{'item_number'} );
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 $class_source = Koha::ClassSources->find( $cn_source );
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
LABEL_FIELDS: # process data for requested fields on current label
for my $field (@$label_fields) {
if ($field->{'code'} eq 'itemtype') {
if ( $field->{'code'} eq 'itemtype' ) {
$field->{'data'} = C4::Context->preference('item-level_itypes') ? $item->{'itype'} : $item->{'itemtype'};
} else {
$field->{'data'} = _get_barcode_data( $field->{'code'}, $item, $record );
}
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,62 +425,70 @@ 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 ($split_routine eq 'LCC' || $split_routine eq 'nlm') { # NLM and LCC should be split the same way
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
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::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);
@label_lines = C4::ClassSplitRoutine::Generic::split_callnumber($field_data) unless @label_lines;
push (@label_lines, $field_data) unless @label_lines;
} elsif ($split_routine eq 'RegEx' ) {
@label_lines = C4::ClassSplitRoutine::RegEx::split_callnumber($field_data, $regexs);
push( @label_lines, $field_data ) unless @label_lines;
} elsif ( $split_routine eq 'RegEx' ) {
@label_lines = C4::ClassSplitRoutine::RegEx::split_callnumber( $field_data, $regexs );
@label_lines = C4::ClassSplitRoutine::Generic::split_callnumber($field_data) unless @label_lines;
push (@label_lines, $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));
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) {
if ( $field->{'code'} eq 'title' && scalar(@line) >= 2 ) {
while ( scalar(@line) > 2 ) {
pop @line;
}
} else {
while (scalar(@line) > 1) {
while ( scalar(@line) > 1 ) {
pop @line;
}
}
push(@label_lines, @line);
push( @label_lines, @line );
}
LABEL_LINES: # generate lines of label text for current field
foreach my $line (@label_lines) {
next LABEL_LINES if $line eq '';
$line = log2vis( $line );
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') {
$line = log2vis($line);
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' ) {
# 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 {
$text_llx = ($params{'llx'} + $self->{'left_text_margin'});
my $whitespace = ( $self->{'width'} - ( $string_width + ( 2 * $self->{'left_text_margin'} ) ) );
$text_llx = ( ( $whitespace / 2 ) + $params{'llx'} + $self->{'left_text_margin'} );
} else {
$text_llx = ( $params{'llx'} + $self->{'left_text_margin'} );
}
push @label_text, {
text_llx => $text_llx,
@ -489,25 +511,26 @@ 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'});
my $num_of_bars = length( $params{'barcode_data'} );
my $tot_bar_length = 0;
my $bar_length = 0;
my $guard_length = 10;
my $hide_text = 'yes';
if ($params{'barcode_type'} =~ m/CODE39/) {
if ( $params{'barcode_type'} =~ m/CODE39/ ) {
$bar_length = '17.5';
$tot_bar_length = ($bar_length * $num_of_bars) + ($guard_length * 2);
$x_scale_factor = ($params{'width'} / $tot_bar_length);
if ($params{'barcode_type'} eq 'CODE39MOD') {
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length );
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') {
$params{'barcode_data'} = $c39->complete( $params{'barcode_data'} );
} elsif ( $params{'barcode_type'} eq 'CODE39MOD10' ) {
my $c39_10 = CheckDigits('siret'); # get modulo43 checksum
$params{'barcode_data'} = $c39_10->complete($params{'barcode_data'});
$params{'barcode_data'} = $c39_10->complete( $params{'barcode_data'} );
$hide_text = '';
}
eval {
@ -523,13 +546,12 @@ sub barcode {
);
};
if ($@) {
warn sprintf('Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@);
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;
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
eval {
PDF::Reuse::Barcode::COOP2of5(
x => $params{'llx'},
@ -541,13 +563,12 @@ sub barcode {
);
};
if ($@) {
warn sprintf('Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@);
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;
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
eval {
PDF::Reuse::Barcode::Industrial2of5(
x => $params{'llx'},
@ -559,40 +580,39 @@ sub barcode {
);
};
if ($@) {
warn sprintf('Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@);
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);
$x_scale_factor = ($params{'width'} / $tot_bar_length) * 0.9;
$tot_bar_length = ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
eval {
PDF::Reuse::Barcode::EAN13(
x => $params{'llx'},
y => $params{'lly'},
value => sprintf('%013d',$params{barcode_data}),
# xSize => $x_scale_factor,
# ySize => $params{'y_scale_factor'},
value => sprintf( '%013d', $params{barcode_data} ),
# xSize => $x_scale_factor,
# ySize => $params{'y_scale_factor'},
mode => 'graphic',
);
};
if ($@) {
warn sprintf('Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@);
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
else {
} else {
warn "unknown barcode_type: $params{barcode_type}";
}
}
sub csv_data {
my $self = shift;
my $label_fields = _get_text_fields($self->{'format_string'});
my $item = _get_label_item($self->{'item_number'});
my $biblio = Koha::Biblios->find($item->{biblionumber});
my $label_fields = _get_text_fields( $self->{'format_string'} );
my $item = _get_label_item( $self->{'item_number'} );
my $biblio = Koha::Biblios->find( $item->{biblionumber} );
my $bib_record = $biblio->metadata->record;
my @csv_data = (map { _get_barcode_data($_->{'code'},$item,$bib_record) } @$label_fields);
my @csv_data = ( map { _get_barcode_data( $_->{'code'}, $item, $bib_record ) } @$label_fields );
return \@csv_data;
}

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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?
}

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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::(.+)::.+$/;

279
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;
@ -30,7 +29,8 @@ use Koha::Caches;
use Koha::Cache::Memory::Lite;
use Koha::Language;
our (@ISA, @EXPORT_OK);
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,26 +72,28 @@ 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;
# find the available directory names
my $dir=C4::Context->config('intranetdir')."/installer/data/";
my $dir = C4::Context->config('intranetdir') . "/installer/data/";
my $dir_h;
opendir ($dir_h,$dir);
my @listdir= grep { !/^\.|CVS/ && -d "$dir/$_"} readdir($dir_h);
opendir( $dir_h, $dir );
my @listdir = grep { !/^\.|CVS/ && -d "$dir/$_" } readdir($dir_h);
closedir $dir_h;
# pull out all data for the dir names that exist
for my $dirname (@listdir) {
for my $language_set (@$all_languages) {
if ($dirname eq $language_set->{language_code}) {
if ( $dirname eq $language_set->{language_code} ) {
push @languages, {
'language_code'=>$dirname,
'language_description'=>$language_set->{language_description},
'native_descrition'=>$language_set->{language_native_description} }
'language_code' => $dirname,
'language_description' => $language_set->{language_description},
'native_descrition' => $language_set->{language_native_description}
};
}
}
}
@ -112,54 +115,52 @@ Returns a reference to an array of hashes:
=cut
sub getTranslatedLanguages {
my ($interface, $theme, $current_language) = @_;
my ( $interface, $theme, $current_language ) = @_;
$interface //= q{};
$theme //= q{};
my @languages;
my @enabled_languages;
if ($interface) {
if ($interface eq 'intranet') {
if ( $interface eq 'intranet' ) {
@enabled_languages = split ",", C4::Context->preference('StaffInterfaceLanguages');
} elsif ($interface eq 'opac') {
} elsif ( $interface eq 'opac' ) {
@enabled_languages = split ",", C4::Context->preference('OPACLanguages');
}
}
my $cache = Koha::Caches->get_instance;
my $cache_key = "languages_${interface}_${theme}";
if ($interface && $interface eq 'opac' ) {
if ( $interface && $interface eq 'opac' ) {
my $htdocs = C4::Context->config('opachtdocs');
my $cached = $cache->get_from_cache($cache_key);
if ( $cached ) {
if ($cached) {
@languages = @{$cached};
} else {
@languages = _get_opac_language_dirs( $htdocs, $theme );
$cache->set_in_cache($cache_key, \@languages );
$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 ) {
if ($cached) {
@languages = @{$cached};
} else {
@languages = _get_intranet_language_dirs( $htdocs, $theme );
$cache->set_in_cache($cache_key, \@languages );
$cache->set_in_cache( $cache_key, \@languages );
}
}
else {
} else {
my $htdocs = C4::Context->config('intrahtdocs');
push @languages, _get_intranet_language_dirs( $htdocs );
push @languages, _get_intranet_language_dirs($htdocs);
$htdocs = C4::Context->config('opachtdocs');
push @languages, _get_opac_language_dirs( $htdocs );
push @languages, _get_opac_language_dirs($htdocs);
my %seen;
$seen{$_}++ for @languages;
@languages = keys %seen;
}
return _build_languages_arrayref(\@languages,$current_language,\@enabled_languages);
return _build_languages_arrayref( \@languages, $current_language, \@enabled_languages );
}
=head2 getAllLanguages
@ -210,7 +211,7 @@ sub getLanguages {
my $language_list = $isFiltered ? C4::Context->preference("AdvancedSearchLanguages") : undef;
my $language_list_cond = $language_list ? 'AND FIND_IN_SET(language_rfc4646_to_iso639.iso639_2_code, ?)' : '';
my $sth = $dbh->prepare("
my $sth = $dbh->prepare( "
SELECT
language_subtag_registry.*,
language_rfc4646_to_iso639.iso639_2_code,
@ -259,16 +260,16 @@ sub getLanguages {
AND native_language_descriptions.type = 'language'
WHERE language_subtag_registry.type = 'language'
${language_list_cond}");
${language_list_cond}" );
if ($language_list) {
$sth->execute($current_language, join ',' => split(/,|\|/, $language_list));
$sth->execute( $current_language, join ',' => split( /,|\|/, $language_list ) );
} else {
$sth->execute($current_language);
}
my @languages_list;
while (my $row = $sth->fetchrow_hashref) {
while ( my $row = $sth->fetchrow_hashref ) {
push @languages_list, $row;
}
return \@languages_list;
@ -279,27 +280,24 @@ sub _get_opac_language_dirs {
my @languages;
if ( $theme and -d "$htdocs/$theme" ) {
(@languages) = _get_language_dirs($htdocs,$theme);
}
else {
(@languages) = _get_language_dirs( $htdocs, $theme );
} else {
for my $theme ( _get_themes('opac') ) {
push @languages, _get_language_dirs($htdocs,$theme);
push @languages, _get_language_dirs( $htdocs, $theme );
}
}
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 {
@languages = _get_language_dirs( $htdocs, $theme );
} else {
foreach my $theme ( _get_themes('intranet') ) {
push @languages, _get_language_dirs($htdocs,$theme);
push @languages, _get_language_dirs( $htdocs, $theme );
}
}
return @languages;
@ -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;
}
@ -342,21 +340,21 @@ Internal function, returns an array of directory names, excluding non-language d
=cut
sub _get_language_dirs {
my ($htdocs,$theme) = @_;
my ( $htdocs, $theme ) = @_;
$htdocs //= '';
$theme //= '';
my @lang_strings;
my $dir_h;
opendir $dir_h, "$htdocs/$theme";
for my $lang_string ( sort readdir $dir_h ) {
next if $lang_string =~/^\./;
next if $lang_string =~ /^\./;
next if $lang_string eq 'all';
next if $lang_string =~/png$/;
next if $lang_string =~/js$/;
next if $lang_string =~/css$/;
next if $lang_string =~/CVS$/;
next if $lang_string =~/\.txt$/i; #Don't read the readme.txt !
next if $lang_string =~/img|images|famfam|js|less|lib|sound|pdf/;
next if $lang_string =~ /png$/;
next if $lang_string =~ /js$/;
next if $lang_string =~ /css$/;
next if $lang_string =~ /CVS$/;
next if $lang_string =~ /\.txt$/i; #Don't read the readme.txt !
next if $lang_string =~ /img|images|famfam|js|less|lib|sound|pdf/;
push @lang_strings, $lang_string;
}
close $dir_h;
@ -372,22 +370,26 @@ FIXME: this could be rewritten and simplified using map
=cut
sub _build_languages_arrayref {
my ($translated_languages,$current_language,$enabled_languages) = @_;
my ( $translated_languages, $current_language, $enabled_languages ) = @_;
$current_language //= '';
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,16 +397,29 @@ 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');
$track_language_groups->{$language_subtags_hashref->{'language'}}++;
push ( @{ $language_groups->{$language_subtags_hashref->{language}} }, $language_subtags_hashref );
$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;
my %idx = map { $enabled_languages->[$_] => $_ } reverse 0 .. @$enabled_languages - 1;
my @ordered_keys = sort {
my $aa = '';
my $bb = '';
@ -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,29 +445,29 @@ 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 ) {
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) {
my $regex_enabled_language = regex_lang_subtags($enabled_language);
$enabled = 1 if $key eq ($regex_enabled_language->{language} // '');
$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'),
native_description => language_get_description( $key, $key, 'language' ),
language => $key,
sublanguages_loop => $value,
plural => $track_language_groups->{$key} >1 ? 1 : 0,
current => ($current_language_regex->{language} // '') eq $key ? 1 : 0,
plural => $track_language_groups->{$key} > 1 ? 1 : 0,
current => ( $current_language_regex->{language} // '' ) eq $key ? 1 : 0,
group_enabled => $enabled,
};
}
@ -462,24 +475,26 @@ sub _build_languages_arrayref {
}
sub language_get_description {
my ($script,$lang,$type) = @_;
my ( $script, $lang, $type ) = @_;
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) {
$sth->execute( $script, $lang, $type );
while ( my $descriptions = $sth->fetchrow_hashref ) {
$desc = $descriptions->{'description'};
}
unless ($desc) {
$sth = $dbh->prepare("SELECT description FROM language_descriptions WHERE subtag=? AND lang=? AND type=?");
$sth->execute($script,'en',$type);
while (my $descriptions = $sth->fetchrow_hashref) {
$sth->execute( $script, 'en', $type );
while ( my $descriptions = $sth->fetchrow_hashref ) {
$desc = $descriptions->{'description'};
}
}
return $desc;
}
=head2 regex_lang_subtags
This internal sub takes a string composed according to RFC 4646 as
@ -500,31 +515,32 @@ sub regex_lang_subtags {
#
# Note: the tool requires that any real "=" or "#" or ";" in the regex be escaped.
my $alpha = qr/[a-zA-Z]/ ; # ALPHA
my $digit = qr/[0-9]/ ; # DIGIT
my $alphanum = qr/[a-zA-Z0-9]/ ; # ALPHA / DIGIT
my $x = qr/[xX]/ ; # private use singleton
my $singleton = qr/[a-w y-z A-W Y-Z]/ ; # other singleton
my $s = qr/[-]/ ; # separator -- lenient parsers will use [-_]
my $alpha = qr/[a-zA-Z]/; # ALPHA
my $digit = qr/[0-9]/; # DIGIT
my $alphanum = qr/[a-zA-Z0-9]/; # ALPHA / DIGIT
my $x = qr/[xX]/; # private use singleton
my $singleton = qr/[a-w y-z A-W Y-Z]/; # other singleton
my $s = qr/[-]/; # separator -- lenient parsers will use [-_]
# Now do the components. The structure is slightly different to allow for capturing the right components.
# The notation (?:....) is a non-capturing version of (...): so the "?:" can be deleted if someone doesn't care about capturing.
my $extlang = qr{(?: $s $alpha{3} )}x ; # *3("-" 3ALPHA)
my $language = qr{(?: $alpha{2,3} | $alpha{4,8} )}x ;
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
my $script = qr{(?: $alpha{4} )}x; # 4ALPHA
my $region = qr{(?: $alpha{2} | $digit{3} )}x ; # 2ALPHA / 3DIGIT
my $region = qr{(?: $alpha{2} | $digit{3} )}x; # 2ALPHA / 3DIGIT
my $variantSub = qr{(?: $digit$alphanum{3} | $alphanum{5,8} )}x ; # *("-" variant), 5*8alphanum / (DIGIT 3alphanum)
my $variant = qr{(?: $variantSub (?: $s$variantSub )* )}x ; # *("-" variant), 5*8alphanum / (DIGIT 3alphanum)
my $variantSub = qr{(?: $digit$alphanum{3} | $alphanum{5,8} )}x; # *("-" variant), 5*8alphanum / (DIGIT 3alphanum)
my $variant = qr{(?: $variantSub (?: $s$variantSub )* )}x; # *("-" variant), 5*8alphanum / (DIGIT 3alphanum)
my $extensionSub = qr{(?: $singleton (?: $s$alphanum{2,8} )+ )}x ; # singleton 1*("-" (2*8alphanum))
my $extension = qr{(?: $extensionSub (?: $s$extensionSub )* )}x ; # singleton 1*("-" (2*8alphanum))
my $extensionSub = qr{(?: $singleton (?: $s$alphanum{2,8} )+ )}x; # singleton 1*("-" (2*8alphanum))
my $extension = qr{(?: $extensionSub (?: $s$extensionSub )* )}x; # singleton 1*("-" (2*8alphanum))
my $privateuse = qr{(?: $x (?: $s$alphanum{1,8} )+ )}x ; # ("x"/"X") 1*("-" (1*8alphanum))
my $privateuse = qr{(?: $x (?: $s$alphanum{1,8} )+ )}x; # ("x"/"X") 1*("-" (1*8alphanum))
# Define certain grandfathered codes, since otherwise the regex is pretty useless.
# Since these are limited, this is safe even later changes to the registry --
@ -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,
@ -568,49 +586,61 @@ sub regex_lang_subtags {
# Script Direction Resources:
# http://www.w3.org/International/questions/qa-scripts
sub get_bidi {
my ($language_script)= @_;
my ($language_script) = @_;
my $dbh = C4::Context->dbh;
my $bidi;
my $sth = $dbh->prepare('SELECT bidi FROM language_script_bidi WHERE rfc4646_subtag=?');
$sth->execute($language_script);
while (my $result = $sth->fetchrow_hashref) {
while ( my $result = $sth->fetchrow_hashref ) {
$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 ( $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);
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 '*');
$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;
$supportedLanguages{ lc($subtag) } = $subtag;
if ( $subtag =~ /^([^-]+)-?/ ) {
$secondaryLanguages{lc($1)} = $subtag;
$secondaryLanguages{ lc($1) } = $subtag;
}
}
@ -618,22 +648,27 @@ sub accept_language {
@languages = sort { $b->{quality} <=> $a->{quality} } @languages;
my $secondaryMatch = '';
foreach my $tag (@languages) {
if (exists($supportedLanguages{$tag->{lclanguage}})) {
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}})) {
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 '') {
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 '') {
} 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 '*') {
} 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.
@ -686,12 +722,12 @@ sub getlanguage {
my $language;
my @languages;
if ($interface eq 'opac' || $interface eq 'intranet') {
if ( $interface eq 'opac' || $interface eq 'intranet' ) {
$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) {
@ -699,24 +735,26 @@ sub getlanguage {
}
# Choose language from the URL
my $cgi_param_language = $cgi->param( 'language' );
if ( defined $cgi_param_language && any { $_ eq $cgi_param_language } @languages) {
my $cgi_param_language = $cgi->param('language');
if ( defined $cgi_param_language && any { $_ eq $cgi_param_language } @languages ) {
$language = $cgi_param_language;
}
# cookie
if (not $language and my $cgi_cookie_language = $cgi->cookie('KohaOpacLanguage') ) {
if ( not $language and my $cgi_cookie_language = $cgi->cookie('KohaOpacLanguage') ) {
( $language = $cgi_cookie_language ) =~ s/[^a-zA-Z_-]*//; # sanitize cookie
}
} else {
@languages = map { $_->{rfc4646_subtag} } @{ getTranslatedLanguages($interface, $theme) };
@languages = map { $_->{rfc4646_subtag} } @{ getTranslatedLanguages( $interface, $theme ) };
$language = Koha::Language->get_requested_language();
}
# 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,8 +781,9 @@ 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});
if ( $rfc_subtag ) {
my $rfc_subtag =
Koha::Database->new()->schema->resultset('LanguageRfc4646ToIso639')->find( { iso639_2_code => $iso_code } );
if ($rfc_subtag) {
return $rfc_subtag->rfc4646_subtag;
} else {
return;

529
C4/Letters.pm
View File

File diff suppressed because it is too large Load Diff

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;
}

41
C4/Linker/Default.pm
View File

@ -36,12 +36,11 @@ sub get_link {
my $fuzzy = 0;
my $match_count;
if ( $self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'cached'} ) {
$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 {
if ( $self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'cached'} ) {
$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 {
# 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,23 +61,23 @@ 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
);
}
}
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'cached'} = 1;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'authid'} = $authid;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'fuzzy'} = $fuzzy;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'match_count'} = $match_count;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'cached'} = 1;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'authid'} = $authid;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'fuzzy'} = $fuzzy;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'match_count'} = $match_count;
}
return $self->SUPER::_handle_auth_limit($authid), $fuzzy, $match_count;
}
@ -95,9 +92,9 @@ sub update_cache {
$thesaurus = 'notconsidered' unless C4::Context->preference('LinkerConsiderThesaurus');
my $fuzzy = 0;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'cached'} = 1;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'authid'} = $authid;
$self->{'cache'}->{$search_form.$auth_type.$thesaurus}->{'fuzzy'} = $fuzzy;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'cached'} = 1;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'authid'} = $authid;
$self->{'cache'}->{ $search_form . $auth_type . $thesaurus }->{'fuzzy'} = $fuzzy;
}
sub flip_heading {

192
C4/MarcModificationTemplates.pm
View File

@ -57,7 +57,6 @@ BEGIN {
);
}
=head1 NAME
C4::MarcModificationTemplates - Module to manage MARC Modification Templates
@ -81,7 +80,7 @@ files telling Koha what fields to insert data into.
=cut
sub GetModificationTemplates {
my ( $template_id ) = @_;
my ($template_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM marc_modification_templates ORDER BY name");
@ -111,16 +110,16 @@ sub AddModificationTemplate {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("INSERT INTO marc_modification_templates ( name ) VALUES ( ? )");
$sth->execute( $template_name );
$sth->execute($template_name);
$sth = $dbh->prepare("SELECT * FROM marc_modification_templates WHERE name = ?");
$sth->execute( $template_name );
$sth->execute($template_name);
my $row = $sth->fetchrow_hashref();
my $template_id = $row->{'template_id'};
if ( $template_id_copy ) {
my @actions = GetModificationTemplateActions( $template_id_copy );
foreach my $action ( @actions ) {
if ($template_id_copy) {
my @actions = GetModificationTemplateActions($template_id_copy);
foreach my $action (@actions) {
AddModificationTemplateAction(
$template_id,
$action->{'action'},
@ -155,11 +154,11 @@ sub AddModificationTemplate {
=cut
sub DelModificationTemplate {
my ( $template_id ) = @_;
my ($template_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("DELETE FROM marc_modification_templates WHERE template_id = ?");
$sth->execute( $template_id );
$sth->execute($template_id);
}
=head2
@ -169,11 +168,11 @@ sub DelModificationTemplate {
=cut
sub GetModificationTemplateAction {
my ( $mmta_id ) = @_;
my ($mmta_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM marc_modification_template_actions WHERE mmta_id = ?");
$sth->execute( $mmta_id );
$sth->execute($mmta_id);
my $action = $sth->fetchrow_hashref();
return $action;
@ -186,11 +185,11 @@ sub GetModificationTemplateAction {
=cut
sub GetModificationTemplateActions {
my ( $template_id ) = @_;
my ($template_id) = @_;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("SELECT * FROM marc_modification_template_actions WHERE template_id = ? ORDER BY ordering");
$sth->execute( $template_id );
$sth->execute($template_id);
my @actions;
while ( my $action = $sth->fetchrow_hashref() ) {
@ -243,8 +242,9 @@ 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 = ?' );
$sth->execute( $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;
@ -273,7 +273,7 @@ sub AddModificationTemplateAction {
)
VALUES ( NULL, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? )";
$sth = $dbh->prepare( $query );
$sth = $dbh->prepare($query);
$sth->execute(
$template_id,
@ -362,7 +362,7 @@ sub ModModificationTemplateAction {
description = ?
WHERE mmta_id = ?";
my $sth = $dbh->prepare( $query );
my $sth = $dbh->prepare($query);
$sth->execute(
$action,
@ -386,7 +386,6 @@ sub ModModificationTemplateAction {
);
}
=head2
DelModificationTemplateAction
@ -396,15 +395,16 @@ sub ModModificationTemplateAction {
=cut
sub DelModificationTemplateAction {
my ( $mmta_id ) = @_;
my ($mmta_id) = @_;
my $action = GetModificationTemplateAction( $mmta_id );
my $action = GetModificationTemplateAction($mmta_id);
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("DELETE FROM marc_modification_template_actions WHERE mmta_id = ?");
$sth->execute( $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 );
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 );
@ -438,27 +441,31 @@ sub MoveModificationTemplateAction {
$ordering-- if ( $where eq 'up' );
$ordering++ if ( $where eq 'down' );
$sth = $dbh->prepare( $query );
$sth = $dbh->prepare($query);
$sth->execute( $action->{'ordering'}, $action->{'template_id'}, $ordering );
## Change the ordering for this action
$query = "UPDATE marc_modification_template_actions SET ordering = ? WHERE mmta_id = ?";
$sth = $dbh->prepare( $query );
$sth = $dbh->prepare($query);
$sth->execute( $ordering, $action->{'mmta_id'} );
} 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 = ?');
$sth->execute( $mmta_id );
$sth->execute($mmta_id);
} elsif ( $where eq 'bottom' ) {
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 = ?');
@ -500,9 +507,9 @@ sub ModifyRecordWithTemplate {
my $branchcode = '';
$branchcode = C4::Context->userenv->{branch} if C4::Context->userenv;
my @actions = GetModificationTemplateActions( $template_id );
my @actions = GetModificationTemplateActions($template_id);
foreach my $a ( @actions ) {
foreach my $a (@actions) {
my $action = $a->{'action'};
my $field_number = $a->{'field_number'} // 1;
my $from_field = $a->{'from_field'};
@ -520,54 +527,62 @@ sub ModifyRecordWithTemplate {
my $conditional_value = $a->{'conditional_value'};
my $conditional_regex = $a->{'conditional_regex'};
if ( $field_value ) {
if ($field_value) {
$field_value =~ s/__CURRENTDATE__/$current_date/g;
$field_value =~ s/__BRANCHCODE__/$branchcode/g;
}
my $do = 1;
my $field_numbers = [];
if ( $conditional ) {
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(
@ -579,20 +594,22 @@ sub ModifyRecordWithTemplate {
)
}
];
$field_numbers = [Koha::MoreUtils::singleton ( @$field_numbers, @$all_fields ) ];
if ( $from_field == $conditional_field ){
$do = $conditional eq 'if'
$field_numbers = [ Koha::MoreUtils::singleton( @$field_numbers, @$all_fields ) ];
if ( $from_field == $conditional_field ) {
$do =
$conditional eq 'if'
? @$field_numbers
: not @$field_numbers;
} else {
$do = $conditional eq 'if'
$do =
$conditional eq 'if'
? not @$field_numbers
: @$field_numbers;
}
}
}
if ( $do ) {
if ($do) {
# field_number == 0 if all field need to be updated
# or 1 if only the first field need to be updated
@ -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 ){
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 ];
$field_numbers = [1];
}
} else {
unless ( $from_field == $conditional_field ){
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 ];
$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 ],
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 ],
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,
});
}
);
}
}
}

306
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;
@ -88,7 +87,7 @@ sub GetMatcherList {
my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
$sth->execute();
my @results = ();
while (my $row = $sth->fetchrow_hashref) {
while ( my $row = $sth->fetchrow_hashref ) {
push @results, $row;
}
return @results;
@ -106,7 +105,7 @@ sub GetMatcherId {
my ($code) = @_;
my $dbh = C4::Context->dbh;
my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
my $matcher_id = $dbh->selectrow_array( "SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code );
return $matcher_id;
}
@ -129,13 +128,13 @@ sub new {
$self->{'id'} = undef;
if ($#_ > -1) {
if ( $#_ > -1 ) {
$self->{'record_type'} = shift;
} else {
$self->{'record_type'} = 'biblio';
}
if ($#_ > -1) {
if ( $#_ > -1 ) {
$self->{'threshold'} = shift;
} else {
$self->{'threshold'} = 1000;
@ -177,25 +176,25 @@ sub fetch {
$self->{'record_type'} = $row->{'record_type'};
$self->{'code'} = $row->{'code'};
$self->{'description'} = $row->{'description'};
$self->{'threshold'} = int($row->{'threshold'});
$self->{'threshold'} = int( $row->{'threshold'} );
bless $self, $class;
# matchpoints
$self->{'matchpoints'} = [];
$sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
$sth->execute($self->{'id'});
while (my $row = $sth->fetchrow_hashref) {
my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
$sth->execute( $self->{'id'} );
while ( my $row = $sth->fetchrow_hashref ) {
my $matchpoint = $self->_fetch_matchpoint( $row->{'matchpoint_id'} );
push @{ $self->{'matchpoints'} }, $matchpoint;
}
# required checks
$self->{'required_checks'} = [];
$sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
$sth->execute($self->{'id'});
while (my $row = $sth->fetchrow_hashref) {
my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
$sth->execute( $self->{'id'} );
while ( my $row = $sth->fetchrow_hashref ) {
my $source_matchpoint = $self->_fetch_matchpoint( $row->{'source_matchpoint_id'} );
my $target_matchpoint = $self->_fetch_matchpoint( $row->{'target_matchpoint_id'} );
my $matchcheck = {};
$matchcheck->{'source_matchpoint'} = $source_matchpoint;
$matchcheck->{'target_matchpoint'} = $target_matchpoint;
@ -215,24 +214,27 @@ sub _fetch_matchpoint {
my $row = $sth->fetchrow_hashref;
my $matchpoint = {};
$matchpoint->{'index'} = $row->{'search_index'};
$matchpoint->{'score'} = int($row->{'score'});
$matchpoint->{'score'} = int( $row->{'score'} );
$sth->finish();
$matchpoint->{'components'} = [];
$sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
$sth->execute($matchpoint_id);
while ($row = $sth->fetchrow_hashref) {
while ( $row = $sth->fetchrow_hashref ) {
my $component = {};
$component->{'tag'} = $row->{'tag'};
$component->{'subfields'} = { map { $_ => 1 } split(//, $row->{'subfields'}) };
$component->{'offset'} = int($row->{'offset'});
$component->{'length'} = int($row->{'length'});
$component->{'subfields'} = { map { $_ => 1 } split( //, $row->{'subfields'} ) };
$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");
$sth2->execute($row->{'matchpoint_component_id'});
while (my $row2 = $sth2->fetchrow_hashref) {
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'};
}
push @{ $matchpoint->{'components'} }, $component;
@ -255,11 +257,13 @@ is replaced.
sub store {
my $self = shift;
if (defined $self->{'id'}) {
if ( defined $self->{'id'} ) {
# update
$self->_del_matcher_components();
$self->_update_marc_matchers();
} else {
# create new
$self->_new_marc_matchers();
}
@ -272,9 +276,10 @@ sub _del_matcher_components {
my $dbh = C4::Context->dbh();
my $sth = $dbh->prepare_cached("DELETE FROM matchpoints WHERE matcher_id = ?");
$sth->execute($self->{'id'});
$sth->execute( $self->{'id'} );
$sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
$sth->execute($self->{'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,23 +289,30 @@ 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 (?, ?, ?, ?)");
$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'});
VALUES (?, ?, ?, ?)"
);
$sth->execute( $self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'} );
$self->{'id'} = $dbh->{'mysql_insertid'};
}
@ -310,19 +322,23 @@ sub _store_matcher_components {
my $dbh = C4::Context->dbh();
my $sth;
my $matcher_id = $self->{'id'};
foreach my $matchpoint (@{ $self->{'matchpoints'}}) {
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->execute($matcher_id, $matchpoint_id);
$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
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
(matcher_id, source_matchpoint_id, target_matchpoint_id)
VALUES (?, ?, ?)");
$sth->execute($matcher_id, $source_matchpoint_id, $target_matchpoint_id);
VALUES (?, ?, ?)"
);
$sth->execute( $matcher_id, $source_matchpoint_id, $target_matchpoint_id );
}
}
@ -334,37 +350,44 @@ 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->execute($matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'}||0);
$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'} }) {
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 (?, ?, ?, ?, ?, ?)");
$sth->bind_param(1, $matchpoint_id);
$sth->bind_param(2, $seqnum);
$sth->bind_param(3, $component->{'tag'});
$sth->bind_param(4, join "", sort keys %{ $component->{'subfields'} });
$sth->bind_param(5, $component->{'offset'}||0);
$sth->bind_param(6, $component->{'length'});
VALUES (?, ?, ?, ?, ?, ?)"
);
$sth->bind_param( 1, $matchpoint_id );
$sth->bind_param( 2, $seqnum );
$sth->bind_param( 3, $component->{'tag'} );
$sth->bind_param( 4, join "", sort keys %{ $component->{'subfields'} } );
$sth->bind_param( 5, $component->{'offset'} || 0 );
$sth->bind_param( 6, $component->{'length'} );
$sth->execute();
my $matchpoint_component_id = $dbh->{'mysql_insertid'};
my $normseq = 0;
foreach my $norm (@{ $component->{'norms'} }) {
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 (?, ?, ?)");
$sth->execute($matchpoint_component_id, $normseq, $norm);
VALUES (?, ?, ?)"
);
$sth->execute( $matchpoint_component_id, $normseq, $norm );
}
}
return $matchpoint_id;
}
=head2 delete
C4::Matcher->delete($id);
@ -481,13 +504,13 @@ to the source string.
sub add_matchpoint {
my $self = shift;
my ($index, $score, $matchcomponents) = @_;
my ( $index, $score, $matchcomponents ) = @_;
my $matchpoint = {};
$matchpoint->{'index'} = $index;
$matchpoint->{'score'} = $score;
$matchpoint->{'components'} = [];
foreach my $input_component (@{ $matchcomponents }) {
foreach my $input_component ( @{$matchcomponents} ) {
push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
}
push @{ $self->{'matchpoints'} }, $matchpoint;
@ -508,14 +531,18 @@ will receive the assigned score.
sub add_simple_matchpoint {
my $self = shift;
my ($index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer) = @_;
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 ]
norms => [$source_normalizer]
}
]);
]
);
}
=head2 add_required_check
@ -552,7 +579,7 @@ to the source string.
sub add_required_check {
my $self = shift;
my ($source_matchpoint, $target_matchpoint) = @_;
my ( $source_matchpoint, $target_matchpoint ) = @_;
my $matchcheck = {};
$matchcheck->{'source_matchpoint'}->{'index'} = '';
@ -561,10 +588,10 @@ sub add_required_check {
$matchcheck->{'target_matchpoint'}->{'index'} = '';
$matchcheck->{'target_matchpoint'}->{'score'} = 0;
$matchcheck->{'target_matchpoint'}->{'components'} = [];
foreach my $input_component (@{ $source_matchpoint }) {
foreach my $input_component ( @{$source_matchpoint} ) {
push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
}
foreach my $input_component (@{ $target_matchpoint }) {
foreach my $input_component ( @{$target_matchpoint} ) {
push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
}
push @{ $self->{'required_checks'} }, $matchcheck;
@ -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]
}
]
);
}
@ -623,7 +662,7 @@ in order of decreasing score, i.e., the best match is first.
sub get_matches {
my $self = shift;
my ($source_record, $max_matches) = @_;
my ( $source_record, $max_matches ) = @_;
my $matches = {};
@ -647,35 +686,41 @@ 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.
# With Elasticsearch this also avoids creating a massive amount of
# ES connectors that would eventually run out of file descriptors.
state $searcher = Koha::SearchEngine::Search->new({index => $Koha::SearchEngine::BIBLIOS_INDEX});
state $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::BIBLIOS_INDEX } );
( $error, $searchresults, $total_hits ) =
$searcher->simple_search_compat( $query, 0, $max_matches, undef, skip_normalize => 1 );
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,11 +732,13 @@ 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 $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,
\@value, undef, 'AuthidAsc'
@ -700,7 +747,7 @@ sub get_matches {
foreach my $result (@$authresults) {
my $id = $result->{authid};
my $target_record = Koha::Authorities->find( $id )->record;
my $target_record = Koha::Authorities->find($id)->record;
$matches->{$id}->{score} += $matchpoint->{'score'};
$matches->{$id}->{record} = $target_record;
}
@ -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') {
if ( $self->{'record_type'} eq 'biblio' ) {
require C4::Biblio;
# get rid of any that don't meet the required checks
$matches = {
map {
@ -728,8 +777,9 @@ sub get_matches {
score => $matches->{$id}->{score}
};
}
} elsif ($self->{'record_type'} eq 'authority') {
} elsif ( $self->{'record_type'} eq 'authority' ) {
require C4::AuthoritiesMarc;
# get rid of any that don't meet the required checks
$matches = {
map {
@ -739,19 +789,16 @@ sub get_matches {
} keys %$matches
};
foreach my $id (keys %$matches) {
foreach my $id ( keys %$matches ) {
push @results, {
record_id => $id,
score => $matches->{$id}->{score}
};
}
}
@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];
@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 ];
}
return @results;
}
@ -777,11 +824,11 @@ sub dump {
$result->{'record_type'} = $self->{'record_type'};
$result->{'matchpoints'} = [];
foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
push @{ $result->{'matchpoints'} }, $matchpoint;
}
$result->{'matchchecks'} = [];
foreach my $matchcheck (@{ $self->{'required_checks'} }) {
foreach my $matchcheck ( @{ $self->{'required_checks'} } ) {
push @{ $result->{'matchchecks'} }, $matchcheck;
}
@ -789,14 +836,14 @@ sub dump {
}
sub _passes_required_checks {
my ($source_record, $target_record, $matchchecks) = @_;
my ( $source_record, $target_record, $matchchecks ) = @_;
# no checks supplied == automatic pass
return 1 if $#{ $matchchecks } == -1;
return 1 if $#{$matchchecks} == -1;
foreach my $matchcheck (@{ $matchchecks }) {
my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
foreach my $matchcheck ( @{$matchchecks} ) {
my $source_key = join "", _get_match_keys( $source_record, $matchcheck->{'source_matchpoint'} );
my $target_key = join "", _get_match_keys( $target_record, $matchcheck->{'target_matchpoint'} );
return 0 unless $source_key eq $target_key;
}
return 1;
@ -824,16 +871,15 @@ sub _get_match_keys {
# second 003 + second 001
my @keys = ();
for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
for ( my $i = 0 ; $i <= $#{ $matchpoint->{'components'} } ; $i++ ) {
my $component = $matchpoint->{'components'}->[$i];
my $j = -1;
my @fields = ();
my $tag = $component->{'tag'};
if ($tag && $tag eq 'LDR'){
if ( $tag && $tag eq 'LDR' ) {
$fields[0] = $source_record->leader();
}
else {
} else {
@fields = $source_record->field($tag);
}
@ -843,43 +889,38 @@ sub _get_match_keys {
last FIELD if $i > 0 and $j > $#keys;
my $string;
if ( ! ref $field ){
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}} ){
} elsif ( defined $component->{subfields} && keys %{ $component->{subfields} } ) {
$string = $field->as_string(
join('', keys %{ $component->{ subfields } }), ' ' # ' ' as separator
join( '', keys %{ $component->{subfields} } ), ' ' # ' ' as separator
);
} else {
$string = $field->as_string();
}
if ($component->{'length'}>0) {
$string= substr($string, $component->{'offset'}, $component->{'length'});
} elsif ($component->{'offset'}) {
$string= substr($string, $component->{'offset'});
if ( $component->{'length'} > 0 ) {
$string = substr( $string, $component->{'offset'}, $component->{'length'} );
} elsif ( $component->{'offset'} ) {
$string = substr( $string, $component->{'offset'} );
}
my $norms = $component->{'norms'};
my $key = $string;
foreach my $norm ( @{ $norms } ) {
foreach my $norm ( @{$norms} ) {
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 {
@ -888,7 +929,7 @@ sub _get_match_keys {
}
}
if ($i == 0) {
if ( $i == 0 ) {
push @keys, $key if $key;
} else {
$keys[$j] .= " $key" if $key;
@ -898,14 +939,13 @@ sub _get_match_keys {
return @keys;
}
sub _parse_match_component {
my $input_component = shift;
my $component = {};
$component->{'tag'} = $input_component->{'tag'};
$component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
$component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
$component->{'subfields'} = { map { $_ => 1 } split( //, $input_component->{'subfields'} ) };
$component->{'offset'} = exists( $input_component->{'offset'} ) ? $input_component->{'offset'} : -1;
$component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
$component->{'norms'} = $input_component->{'norms'} ? $input_component->{'norms'} : [];

100
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 );
@ -37,7 +36,8 @@ use Koha::AdditionalContents;
use Koha::Patrons;
use Koha::Patron::Categories;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -128,8 +128,8 @@ The "message" field that comes from the DB is OK.
# DEPRECATED Do not use this subroutine!
sub patronflags {
my %flags;
my ( $patroninformation) = @_;
my $dbh=C4::Context->dbh;
my ($patroninformation) = @_;
my $dbh = C4::Context->dbh;
my $patron = Koha::Patrons->find( $patroninformation->{borrowernumber} );
my $account = $patron->account;
my $patron_charge_limits = $patron->is_patron_inside_charge_limits();
@ -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;
@ -194,21 +194,18 @@ sub patronflags {
$flaginfo{'message'} = $patroninformation->{'borrowernotes'};
$flags{'NOTES'} = \%flaginfo;
}
my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues($patroninformation->{'borrowernumber'});
my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues( $patroninformation->{'borrowernumber'} );
if ( $odues && $odues > 0 ) {
my %flaginfo;
$flaginfo{'message'} = "Yes";
$flaginfo{'itemlist'} = $itemsoverdue;
foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
@$itemsoverdue )
{
$flaginfo{'itemlisttext'} .=
"$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # 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;
}
my $waiting_holds = $patron->holds->search({ found => 'W' });
my $waiting_holds = $patron->holds->search( { found => 'W' } );
my $nowaiting = $waiting_holds->count;
if ( $nowaiting > 0 ) {
my %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;
@ -266,7 +267,7 @@ sub GetBorrowersToExpunge {
) as tmp ON borrowers.borrowernumber=tmp.guarantor_id
LEFT JOIN old_issues USING (borrowernumber)
LEFT JOIN issues USING (borrowernumber)|;
if ( $filterpatronlist ){
if ($filterpatronlist) {
$query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
}
$query .= q| WHERE category_type <> 'S'
@ -276,36 +277,36 @@ sub GetBorrowersToExpunge {
|;
my @query_params;
if ( $filterbranch && $filterbranch ne "" ) {
$query.= " AND borrowers.branchcode = ? ";
$query .= " AND borrowers.branchcode = ? ";
push( @query_params, $filterbranch );
}
if ( $filterexpiry ) {
if ($filterexpiry) {
$query .= " AND dateexpiry < ? ";
push( @query_params, $filterexpiry );
}
if ( $filterlastseen ) {
if ($filterlastseen) {
$query .= ' AND lastseen < ? ';
push @query_params, $filterlastseen;
}
if ( $filtercategory ) {
if (ref($filtercategory) ne 'ARRAY' ) {
$filtercategory = [ $filtercategory ];
if ($filtercategory) {
if ( ref($filtercategory) ne 'ARRAY' ) {
$filtercategory = [$filtercategory];
}
if ( @$filtercategory ) {
$query .= " AND categorycode IN (" . join(',', ('?') x @$filtercategory) . ") ";
if (@$filtercategory) {
$query .= " AND categorycode IN (" . join( ',', ('?') x @$filtercategory ) . ") ";
push( @query_params, @$filtercategory );
}
}
if ( $filterpatronlist ){
$query.=" AND patron_list_id = ? ";
if ($filterpatronlist) {
$query .= " AND patron_list_id = ? ";
push( @query_params, $filterpatronlist );
}
$query .= " GROUP BY borrowers.borrowernumber";
$query .= q|
) xxx WHERE currentissue IS NULL|;
if ( $filterdate ) {
$query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
push @query_params,$filterdate;
if ($filterdate) {
$query .= " AND ( latestissue < ? OR latestissue IS NULL ) ";
push @query_params, $filterdate;
}
if ( my $anonymous_patron = C4::Context->preference("AnonymousPatron") ) {
@ -314,10 +315,9 @@ sub GetBorrowersToExpunge {
}
my $sth = $dbh->prepare($query);
if (scalar(@query_params)>0){
if ( scalar(@query_params) > 0 ) {
$sth->execute(@query_params);
}
else {
} else {
$sth->execute;
}
@ -377,22 +377,22 @@ sub GetBorrowersToExpunge {
=cut
sub IssueSlip {
my ($branch, $borrowernumber, $quickslip) = @_;
my ( $branch, $borrowernumber, $quickslip ) = @_;
# FIXME Check callers before removing this statement
#return unless $borrowernumber;
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
return unless $patron;
my $pending_checkouts = $patron->pending_checkouts; # Should be $patron->checkouts->pending?
my ($letter_code, %repeat, %loops);
if ( $quickslip ) {
my ( $letter_code, %repeat, %loops );
if ($quickslip) {
my $today_start = dt_from_string->set( hour => 0, minute => 0, second => 0 );
my $today_end = dt_from_string->set( hour => 23, minute => 59, second => 0 );
$today_start = Koha::Database->new->schema->storage->datetime_parser->format_datetime( $today_start );
$today_end = Koha::Database->new->schema->storage->datetime_parser->format_datetime( $today_end );
$today_start = Koha::Database->new->schema->storage->datetime_parser->format_datetime($today_start);
$today_end = Koha::Database->new->schema->storage->datetime_parser->format_datetime($today_end);
$letter_code = 'ISSUEQSLIP';
# issue date or lastreneweddate is today
@ -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 {
my $today = Koha::Database->new->schema->storage->datetime_parser->format_datetime( dt_from_string );
} 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 = $pending_checkouts->search( { date_due => { '>' => $today } } );
my @checkouts;
my @overdues;
while ( my $c = $checkouts->next ) {
my $all = $c->unblessed_all_relateds;
push @checkouts, {
@ -442,7 +442,7 @@ sub IssueSlip {
}
# Checkouts due in the past are overdues
my $overdues = $pending_checkouts->search({ date_due => { '<=' => $today } });
my $overdues = $pending_checkouts->search( { date_due => { '<=' => $today } } );
while ( my $o = $overdues->next ) {
my $all = $o->unblessed_all_relateds;
push @overdues, {
@ -473,7 +473,7 @@ sub IssueSlip {
);
}
return C4::Letters::GetPreparedLetter (
return C4::Letters::GetPreparedLetter(
module => 'circulation',
letter_code => $letter_code,
branchcode => $branch,

51
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
@ -90,7 +88,7 @@ END_SQL
my $sth = C4::Context->dbh->prepare($sql);
$sth->execute(@bind_params);
my $return;
ROW: while ( my $row = $sth->fetchrow_hashref() ) {
ROW: while ( my $row = $sth->fetchrow_hashref() ) {
next ROW unless $row->{'message_attribute_id'};
$return->{'days_in_advance'} = $row->{'days_in_advance'} if defined $row->{'days_in_advance'};
$return->{'wants_digest'} = $row->{'wants_digest'} if defined $row->{'wants_digest'};
@ -121,18 +119,18 @@ returns nothing useful.
sub SetMessagingPreference {
my $params = shift;
unless (exists $params->{borrowernumber} xor exists $params->{categorycode}) { # yes, xor
unless ( exists $params->{borrowernumber} xor exists $params->{categorycode} ) { # yes, xor
warn "SetMessagingPreference called without exactly one of borrowernumber or categorycode";
return;
}
foreach my $required ( qw( message_attribute_id message_transport_types ) ) {
if ( ! exists $params->{ $required } ) {
foreach my $required (qw( message_attribute_id message_transport_types )) {
if ( !exists $params->{$required} ) {
warn "SetMessagingPreference called without required parameter: $required";
return;
}
}
$params->{'days_in_advance'} = undef unless exists ( $params->{'days_in_advance'} );
$params->{'wants_digest'} = 0 unless exists ( $params->{'wants_digest'} );
$params->{'days_in_advance'} = undef unless exists( $params->{'days_in_advance'} );
$params->{'wants_digest'} = 0 unless exists( $params->{'wants_digest'} );
my $dbh = C4::Context->dbh();
@ -148,8 +146,8 @@ END_SQL
$delete_sql .= " AND categorycode = ? ";
push @bind_params, $params->{categorycode};
}
my $sth = $dbh->prepare( $delete_sql );
my $deleted = $sth->execute( @bind_params );
my $sth = $dbh->prepare($delete_sql);
my $deleted = $sth->execute(@bind_params);
if ( $params->{'message_transport_types'} ) {
my $insert_bmp = <<'END_SQL';
@ -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'},
$params->{'borrowernumber'} = undef unless exists( $params->{'borrowernumber'} );
$params->{'categorycode'} = undef unless exists( $params->{'categorycode'} );
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'};
@ -178,7 +180,7 @@ VALUES
(?, ?)
END_SQL
$sth = C4::Context->dbh()->prepare($insert_bmtp);
foreach my $transport ( @{$params->{'message_transport_types'}}) {
foreach my $transport ( @{ $params->{'message_transport_types'} } ) {
my $success = $sth->execute( $borrower_message_preference_id, $transport );
}
}
@ -210,7 +212,7 @@ END_SQL
$choices->{ $row->{'message_name'} }->{'message_name'} = $row->{'message_name'};
$choices->{ $row->{'message_name'} }->{'takes_days'} = $row->{'takes_days'};
$choices->{ $row->{'message_name'} }->{'has_digest'} = 1 if $row->{'is_digest'};
$choices->{ $row->{'message_name'} }->{'transport_' . $row->{'message_transport_type'}} = ' ';
$choices->{ $row->{'message_name'} }->{ 'transport_' . $row->{'message_transport_type'} } = ' ';
}
my @return = values %$choices;
@ -253,19 +255,24 @@ whatever defaults are defined for the patron category.
sub SetMessagingPreferencesFromDefaults {
my $params = shift;
foreach my $required ( qw( borrowernumber categorycode ) ) {
unless ( exists $params->{ $required } ) {
foreach my $required (qw( borrowernumber categorycode )) {
unless ( exists $params->{$required} ) {
die "SetMessagingPreferencesFromDefaults called without required parameter: $required";
}
}
my $messaging_options = GetMessagingOptions();
OPTION: foreach my $option ( @$messaging_options ) {
OPTION: foreach my $option (@$messaging_options) {
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
@ -273,7 +280,7 @@ sub SetMessagingPreferencesFromDefaults {
$default_pref->{message_attribute_id} = $option->{'message_attribute_id'};
$default_pref->{message_transport_types} = \@message_transport_types;
$default_pref->{borrowernumber} = $params->{borrowernumber};
SetMessagingPreference( $default_pref );
SetMessagingPreference($default_pref);
}
}

19
C4/Members/Statistics.pm
View File

@ -52,16 +52,16 @@ sub get_fields {
my $syspref = C4::Context->preference('StatisticsFields');
my $ret;
if ( $syspref ) {
if ($syspref) {
my @ret;
my @spfields = split ('\|', $syspref);
my @spfields = split( '\|', $syspref );
my $schema = Koha::Database->new()->schema();
my @columns = $schema->source('Item')->columns;
foreach my $fn ( @spfields ) {
push ( @ret, $fn ) if ( grep { $_ eq $fn } @columns );
foreach my $fn (@spfields) {
push( @ret, $fn ) if ( grep { $_ eq $fn } @columns );
}
$ret = join( '|', @ret);
$ret = join( '|', @ret );
}
return $ret || 'location|itype|ccode';
}
@ -106,7 +106,7 @@ sub GetTotalIssuesTodayByBorrower {
) tmp"; # alias is required by MySQL
my $sth = $dbh->prepare($query);
$sth->execute($borrowernumber, $borrowernumber);
$sth->execute( $borrowernumber, $borrowernumber );
return $sth->fetchall_arrayref( {} );
}
@ -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);
@ -143,8 +144,8 @@ sub GetPrecedentStateByBorrower {
) tmp"; # alias is required by MySQL
my $sth = $dbh->prepare($query);
$sth->execute($borrowernumber, $borrowernumber);
return $sth->fetchall_arrayref( {});
$sth->execute( $borrowernumber, $borrowernumber );
return $sth->fetchall_arrayref( {} );
}
1;

59
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)
@ -82,12 +79,11 @@ This method creates an in-memory version of a message object.
# C4::Message->new(\%attributes) -- constructor
sub new {
my ($class, $opts) = @_;
my ( $class, $opts ) = @_;
$opts ||= {};
bless {%$opts} => $class;
}
=head3 C4::Message->find($id)
This method searches the message_queue table for a row with the given
@ -97,7 +93,7 @@ C<message_id> and it'll return a C4::Message object if it finds one.
# C4::Message->find($id) -- find a message by its message_id
sub find {
my ($class, $id) = @_;
my ( $class, $id ) = @_;
my $dbh = C4::Context->dbh;
my $msgs = $dbh->selectall_arrayref(
qq{SELECT * FROM message_queue WHERE message_id = ?},
@ -105,7 +101,7 @@ sub find {
$id,
);
if (@$msgs) {
return $class->new($msgs->[0]);
return $class->new( $msgs->[0] );
} else {
return;
}
@ -122,7 +118,8 @@ message before it gets sent out.)
# C4::Message->find_last_message($borrower, $letter_code, $transport)
# -- get the borrower's most recent pending checkin or checkout notification
sub find_last_message {
my ($class, $borrower, $letter_code, $transport) = @_;
my ( $class, $borrower, $letter_code, $transport ) = @_;
# $type is the message_transport_type
$transport ||= 'email';
my $dbh = C4::Context->dbh;
@ -141,13 +138,12 @@ sub find_last_message {
$transport,
);
if (@$msgs) {
return $class->new($msgs->[0]);
return $class->new( $msgs->[0] );
} else {
return;
}
}
=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;
}
@ -202,8 +193,8 @@ sub _to_address {
# _metadata($letter) -- return the letter split into head/body/footer
sub _metadata {
my ($letter) = @_;
if ($letter->{content} =~ /----/) {
my ($header, $body, $footer) = split(/----\r?\n?/, $letter->{content});
if ( $letter->{content} =~ /----/ ) {
my ( $header, $body, $footer ) = split( /----\r?\n?/, $letter->{content} );
return {
header => $header,
body => [$body],
@ -212,7 +203,7 @@ sub _metadata {
} else {
return {
header => '',
body => [$letter->{content}],
body => [ $letter->{content} ],
footer => '',
};
}
@ -274,26 +265,26 @@ attribute. (It is stored in YAML format.)
# $object->metadata -- this is a YAML serialized column that contains a
# structured representation of $object->content
sub metadata {
my ($self, $data) = @_;
my ( $self, $data ) = @_;
if ($data) {
$data->{header} ||= '';
$data->{body} ||= [];
$data->{footer} ||= '';
$self->{metadata} = Encode::decode_utf8(Dump($data));
$self->content($self->render_metadata);
$self->{metadata} = Encode::decode_utf8( Dump($data) );
$self->content( $self->render_metadata );
return $data;
} else {
return YAML::XS::Load(Encode::encode_utf8($self->{metadata}));
return YAML::XS::Load( Encode::encode_utf8( $self->{metadata} ) );
}
}
# turn $object->metadata into a string suitable for $object->content
sub render_metadata {
my ($self, $format) = @_;
my ( $self, $format ) = @_;
$format ||= sub { $_[0] || "" };
my $metadata = $self->metadata;
my $body = $metadata->{body};
my $text = join('', map { $format->($_) } @$body);
my $text = join( '', map { $format->($_) } @$body );
return $metadata->{header} . $text . $metadata->{footer};
}
@ -311,9 +302,9 @@ If passed a string, it'll append the string to the message.
# $object->append($letter_or_item) -- add a new item to a message's content
sub append {
my ($self, $letter_or_item, $format) = @_;
my ( $self, $letter_or_item, $format ) = @_;
my ( $item, $header, $footer );
if (ref($letter_or_item)) {
if ( ref($letter_or_item) ) {
my $letter = $letter_or_item;
my $metadata = _metadata($letter);
$header = $metadata->{header};
@ -322,12 +313,12 @@ sub append {
} else {
$item = $letter_or_item;
}
if (not $self->metadata) {
if ( not $self->metadata ) {
carp "Can't append to messages that don't have metadata.";
return;
}
my $metadata = $self->metadata;
push @{$metadata->{body}}, $item;
push @{ $metadata->{body} }, $item;
$metadata->{header} = $header;
$metadata->{footer} = $footer;
$self->metadata($metadata);
@ -387,11 +378,11 @@ sub append {
# $object->$method -- treat keys as methods
sub AUTOLOAD {
my ($self, @args) = @_;
my ( $self, @args ) = @_;
my $attr = $AUTOLOAD;
$attr =~ s/.*://;
if (ref($self->{$attr}) eq 'CODE') {
$self->{$attr}->($self, @args);
if ( ref( $self->{$attr} ) eq 'CODE' ) {
$self->{$attr}->( $self, @args );
} else {
if (@args) {
$self->{$attr} = $args[0];

102
C4/OAI/Sets.pm
View File

@ -74,7 +74,7 @@ sub GetOAISets {
};
my $sth = $dbh->prepare($query);
$sth->execute;
my $results = $sth->fetchall_arrayref({});
my $results = $sth->fetchall_arrayref( {} );
$query = qq{
SELECT description
@ -83,10 +83,10 @@ sub GetOAISets {
};
$sth = $dbh->prepare($query);
foreach my $set (@$results) {
$sth->execute($set->{'id'});
my $desc = $sth->fetchall_arrayref({});
$sth->execute( $set->{'id'} );
my $desc = $sth->fetchall_arrayref( {} );
foreach (@$desc) {
push @{$set->{'descriptions'}}, $_->{'description'};
push @{ $set->{'descriptions'} }, $_->{'description'};
}
}
@ -124,10 +124,10 @@ sub GetOAISet {
WHERE set_id = ?
};
$sth = $dbh->prepare($query);
$sth->execute($set->{'id'});
my $desc = $sth->fetchall_arrayref({});
$sth->execute( $set->{'id'} );
my $desc = $sth->fetchall_arrayref( {} );
foreach (@$desc) {
push @{$set->{'descriptions'}}, $_->{'description'};
push @{ $set->{'descriptions'} }, $_->{'description'};
}
return $set;
@ -176,9 +176,9 @@ ModOAISet modify a set in the database.
sub ModOAISet {
my ($set) = @_;
return unless($set && $set->{'spec'} && $set->{'name'});
return unless ( $set && $set->{'spec'} && $set->{'name'} );
if(!defined $set->{'id'}) {
if ( !defined $set->{'id'} ) {
warn "Set ID not defined, can't modify the set";
return;
}
@ -191,24 +191,24 @@ sub ModOAISet {
WHERE id = ?
};
my $sth = $dbh->prepare($query);
$sth->execute($set->{'spec'}, $set->{'name'}, $set->{'id'});
$sth->execute( $set->{'spec'}, $set->{'name'}, $set->{'id'} );
if($set->{'descriptions'}) {
if ( $set->{'descriptions'} ) {
$query = qq{
DELETE FROM oai_sets_descriptions
WHERE set_id = ?
};
$sth = $dbh->prepare($query);
$sth->execute($set->{'id'});
$sth->execute( $set->{'id'} );
if(scalar @{$set->{'descriptions'}} > 0) {
if ( scalar @{ $set->{'descriptions'} } > 0 ) {
$query = qq{
INSERT INTO oai_sets_descriptions (set_id, description)
VALUES (?,?)
};
$sth = $dbh->prepare($query);
foreach (@{ $set->{'descriptions'} }) {
$sth->execute($set->{'id'}, $_) if $_;
foreach ( @{ $set->{'descriptions'} } ) {
$sth->execute( $set->{'id'}, $_ ) if $_;
}
}
}
@ -256,7 +256,7 @@ AddOAISet adds a new set and returns its id, or undef if something went wrong.
sub AddOAISet {
my ($set) = @_;
return unless($set && $set->{'spec'} && $set->{'name'});
return unless ( $set && $set->{'spec'} && $set->{'name'} );
my $set_id;
my $dbh = C4::Context->dbh;
@ -265,16 +265,16 @@ sub AddOAISet {
VALUES (?,?)
};
my $sth = $dbh->prepare($query);
if( $sth->execute($set->{'spec'}, $set->{'name'}) ) {
$set_id = $dbh->last_insert_id(undef, undef, 'oai_sets', undef);
if($set->{'descriptions'}) {
if ( $sth->execute( $set->{'spec'}, $set->{'name'} ) ) {
$set_id = $dbh->last_insert_id( undef, undef, 'oai_sets', undef );
if ( $set->{'descriptions'} ) {
$query = qq{
INSERT INTO oai_sets_descriptions (set_id, description)
VALUES (?,?)
};
$sth = $dbh->prepare($query);
foreach( @{ $set->{'descriptions'} } ) {
$sth->execute($set_id, $_) if $_;
foreach ( @{ $set->{'descriptions'} } ) {
$sth->execute( $set_id, $_ ) if $_;
}
}
} else {
@ -338,8 +338,8 @@ sub GetOAISetsMappings {
$sth->execute;
my $mappings = {};
while(my $result = $sth->fetchrow_hashref) {
push @{ $mappings->{$result->{'set_id'}} }, {
while ( my $result = $sth->fetchrow_hashref ) {
push @{ $mappings->{ $result->{'set_id'} } }, {
marcfield => $result->{'marcfield'},
marcsubfield => $result->{'marcsubfield'},
operator => $result->{'operator'},
@ -376,7 +376,7 @@ sub GetOAISetMappings {
$sth->execute($set_id);
my @mappings;
while(my $result = $sth->fetchrow_hashref) {
while ( my $result = $sth->fetchrow_hashref ) {
push @mappings, {
marcfield => $result->{'marcfield'},
marcsubfield => $result->{'marcsubfield'},
@ -408,7 +408,7 @@ ModOAISetMappings modifies mappings of a given set.
=cut
sub ModOAISetMappings {
my ($set_id, $mappings) = @_;
my ( $set_id, $mappings ) = @_;
return unless $set_id;
@ -419,14 +419,17 @@ sub ModOAISetMappings {
};
my $sth = $dbh->prepare($query);
$sth->execute($set_id);
if(scalar @$mappings > 0) {
if ( scalar @$mappings > 0 ) {
$query = qq{
INSERT INTO oai_sets_mappings (set_id, marcfield, marcsubfield, operator, marcvalue, rule_operator, rule_order)
VALUES (?,?,?,?,?,?,?)
};
$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'}
);
}
}
}
@ -455,7 +458,7 @@ sub GetOAISetsBiblio {
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
return $sth->fetchall_arrayref({});
return $sth->fetchall_arrayref( {} );
}
=head2 DelOAISetsBiblio
@ -491,41 +494,41 @@ GetOAISetsMappings
=cut
sub CalcOAISetsBiblio {
my ($record, $oai_sets_mappings) = @_;
my ( $record, $oai_sets_mappings ) = @_;
return unless $record;
$oai_sets_mappings ||= GetOAISetsMappings;
my @biblio_sets;
foreach my $set_id (keys %$oai_sets_mappings) {
foreach my $set_id ( keys %$oai_sets_mappings ) {
my $rules = [];
foreach my $mapping (@{ $oai_sets_mappings->{$set_id} }) {
foreach my $mapping ( @{ $oai_sets_mappings->{$set_id} } ) {
next if not $mapping;
my $rule_operator = $mapping->{'rule_operator'};
my $result = _evalRule($record, $mapping);
my $result = _evalRule( $record, $mapping );
# First rule or 'or' rule is always pushed
if (!@$rules || $rule_operator eq 'or') {
if ( !@$rules || $rule_operator eq 'or' ) {
push @$rules, [$result];
next;
}
# 'and' rule is pushed in the last 'or' rule
push @{$rules->[-1]}, $result;
push @{ $rules->[-1] }, $result;
}
my @evaluated_and;
foreach my $ruleset (@$rules) {
if (0 < grep /0/, @{$ruleset}) {
if ( 0 < grep /0/, @{$ruleset} ) {
push @evaluated_and, 0;
} else {
push @evaluated_and, 1;
}
}
if (grep /1/, @evaluated_and) {
if ( grep /1/, @evaluated_and ) {
push @biblio_sets, $set_id;
}
@ -544,30 +547,31 @@ 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 ) {
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;
}
}
if ($operator eq 'notequal') {
if(0 == grep { $_ eq $value } @all_subfield_values) {
if ( $operator eq 'notequal' ) {
if ( 0 == grep { $_ eq $value } @all_subfield_values ) {
return 1;
}
}
else {
if(0 < grep { $_ eq $value } @all_subfield_values) {
} else {
if ( 0 < grep { $_ eq $value } @all_subfield_values ) {
return 1;
}
}
return 0;
}
=head2 ModOAISetsBiblios
my $oai_sets_biblios = {
@ -606,12 +610,12 @@ $record is a MARC::Record.
=cut
sub UpdateOAISetsBiblio {
my ($biblionumber, $record) = @_;
my ( $biblionumber, $record ) = @_;
return unless($biblionumber and $record);
return unless ( $biblionumber and $record );
$record = $record->clone;
if (C4::Context->preference('OAI-PMH:AutoUpdateSetsEmbedItemData')) {
if ( C4::Context->preference('OAI-PMH:AutoUpdateSetsEmbedItemData') ) {
$record = Koha::Biblio::Metadata->record(
{
record => $record,
@ -655,9 +659,9 @@ sub AddOAISetsBiblios {
VALUES (?,?)
};
my $sth = $dbh->prepare($query);
foreach my $set_id (keys %$oai_sets_biblios) {
foreach my $biblionumber (@{$oai_sets_biblios->{$set_id}}) {
$sth->execute($set_id, $biblionumber);
foreach my $set_id ( keys %$oai_sets_biblios ) {
foreach my $biblionumber ( @{ $oai_sets_biblios->{$set_id} } ) {
$sth->execute( $set_id, $biblionumber );
}
}
}

106
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.
@ -35,7 +34,7 @@ use C4::Auth qw( get_template_and_user );
use C4::Context;
use C4::Templates;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ -78,7 +77,7 @@ This function returns HTML, without any language dependency.
=cut
sub pagination_bar {
my $base_url = (@_ ? shift : return);
my $base_url = ( @_ ? shift : return );
my $nb_pages = (@_) ? shift : 1;
my $current_page = (@_) ? shift : undef; # delay default until later
my $startfrom_name = (@_) ? shift : 'page';
@ -94,14 +93,14 @@ sub pagination_bar {
my $delim = qr/\&(?:amp;)?|;/; # "non memory" cluster: no backreference
$base_url =~ s/$delim*\b$startfrom_name=(\d+)//g; # remove previous pagination var
unless (defined $current_page and $current_page > 0 and $current_page <= $nb_pages) {
unless ( defined $current_page and $current_page > 0 and $current_page <= $nb_pages ) {
$current_page = ($1) ? $1 : 1; # pull current page from param in URL, else default to 1
}
$base_url =~ s/($delim)+/$1/g; # compress duplicate delims
$base_url =~ s/$delim;//g; # remove empties
$base_url =~ s/$delim$//; # remove trailing delim
my $url = $base_url . (($base_url =~ m/$delim/ or $base_url =~ m/\?/) ? '&amp;' : '?' ) . $startfrom_name . '=';
my $url = $base_url . ( ( $base_url =~ m/$delim/ or $base_url =~ m/\?/ ) ? '&amp;' : '?' ) . $startfrom_name . '=';
my $url_suffix = '';
while ( my ( $k, $v ) = each %$additional_parameters ) {
$url_suffix .= '&amp;' . URI::Escape::uri_escape_utf8($k) . '=' . URI::Escape::uri_escape_utf8($v);
@ -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',
@ -273,13 +239,13 @@ sub output_with_http_headers {
if C4::Context->preference('AccessControlAllowOrigin');
$options->{cookie} = $cookie if $cookie;
if ($content_type eq 'html') { # guaranteed to be one of the content_type_map keys, else we'd have died
$options->{'Content-Style-Type' } = 'text/css';
if ( $content_type eq 'html' ) { # guaranteed to be one of the content_type_map keys, else we'd have died
$options->{'Content-Style-Type'} = 'text/css';
$options->{'Content-Script-Type'} = 'text/javascript';
}
# We can't encode here, that will double encode our templates, and xslt
# We need to fix the encoding as it comes out of the database, or when we pass the variables to templates
# We can't encode here, that will double encode our templates, and xslt
# We need to fix the encoding as it comes out of the database, or when we pass the variables to templates
$data =~ s/\&amp\;amp\; /\&amp\; /g;
print $query->header($options), $data;
@ -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(
@ -378,7 +340,7 @@ sub output_and_exit_if_error {
sub output_and_exit {
my ( $query, $cookie, $template, $error ) = @_;
$template->param( blocking_error => $error );
output_html_with_http_headers ( $query, $cookie, $template->output );
output_html_with_http_headers( $query, $cookie, $template->output );
exit;
}
@ -393,7 +355,7 @@ sub output_error {
}
);
my $admin = C4::Context->preference('KohaAdminEmailAddress');
$template->param (
$template->param(
admin => $admin,
errno => $error,
);
@ -404,7 +366,7 @@ sub parametrized_url {
my $url = shift || ''; # ie page.pl?ln={LANG}
my $vars = shift || {}; # ie { LANG => en }
my $ret = $url;
while ( my ($key,$val) = each %$vars) {
while ( my ( $key, $val ) = each %$vars ) {
my $val_url = URI::Escape::uri_escape_utf8( $val // q{} );
$ret =~ s/\{$key\}/$val_url/g;
}

4
C4/Output/JSONStream.pm
View File

@ -60,8 +60,8 @@ sub param {
die 'param() received odd number of arguments (should be called with param => "value" pairs)';
}
for ( my $i = 0; $i < $#_; $i += 2 ) {
$self->{data}->{$_[$i]} = $_[$i + 1];
for ( my $i = 0 ; $i < $#_ ; $i += 2 ) {
$self->{data}->{ $_[$i] } = $_[ $i + 1 ];
}
}

159
C4/Overdues.pm
View File

@ -1,6 +1,5 @@
package C4::Overdues;
# Copyright 2000-2002 Katipo Communications
# copyright 2010 BibLibre
#
@ -37,7 +36,8 @@ use Koha::Recalls;
use Koha::Logger;
use Koha::Patrons;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -119,12 +119,11 @@ LEFT JOIN biblioitems USING (biblioitemnumber)
push @bind_parameters, $params->{'maximumdays'};
}
$statement .= 'ORDER BY borrowernumber';
my $sth = $dbh->prepare( $statement );
$sth->execute( @bind_parameters );
return $sth->fetchall_arrayref({});
my $sth = $dbh->prepare($statement);
$sth->execute(@bind_parameters);
return $sth->fetchall_arrayref( {} );
}
=head2 checkoverdues
($count, $overdueitems) = checkoverdues($borrowernumber);
@ -172,8 +171,8 @@ sub checkoverdues {
AND issues.date_due < NOW()"
);
$sth->execute($borrowernumber);
my $results = $sth->fetchall_arrayref({});
return ( scalar(@$results), $results); # returning the count and the results is silly
my $results = $sth->fetchall_arrayref( {} );
return ( scalar(@$results), $results ); # returning the count and the results is silly
}
=head2 CalcFine
@ -221,9 +220,10 @@ sub CalcFine {
my ( $item, $bortype, $branchcode, $due_dt, $end_date ) = @_;
# Skip calculations if item is not overdue
return ( 0, 0, 0 ) unless (DateTime->compare( $due_dt, $end_date ) == -1);
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(
@ -250,33 +250,40 @@ sub CalcFine {
my $fine_unit = $issuing_rule->{lengthunit} || 'days';
my $chargeable_units = get_chargeable_units($fine_unit, $start_date, $end_date, $branchcode);
my $units_minus_grace = $chargeable_units - ($issuing_rule->{firstremind} || 0);
my $chargeable_units = get_chargeable_units( $fine_unit, $start_date, $end_date, $branchcode );
my $units_minus_grace = $chargeable_units - ( $issuing_rule->{firstremind} || 0 );
my $amount = 0;
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
my @recalls = Koha::Recalls->search({ biblio_id => $item->{biblionumber}, status => 'overdue' })->as_list;
my @recalls = Koha::Recalls->search( { biblio_id => $item->{biblionumber}, status => 'overdue' } )->as_list;
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} ) {
foreach my $recall (@recalls) {
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}) {
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);
return ( $amount, $units_minus_grace, $chargeable_units );
}
=head2 get_chargeable_units
get_chargeable_units($unit, $start_date_ $end_date, $branchcode);
@ -316,37 +325,35 @@ C<$branchcode> is the branch whose calendar to use for finding holidays.
=cut
sub get_chargeable_units {
my ($unit, $date_due, $date_returned, $branchcode) = @_;
my ( $unit, $date_due, $date_returned, $branchcode ) = @_;
# If the due date is later than the return date
return 0 unless ( $date_returned > $date_due );
my $charge_units = 0;
my $charge_duration;
if ($unit eq 'hours') {
if(C4::Context->preference('finesCalendar') eq 'noFinesWhenClosed') {
if ( $unit eq 'hours' ) {
if ( C4::Context->preference('finesCalendar') eq 'noFinesWhenClosed' ) {
my $calendar = Koha::Calendar->new( branchcode => $branchcode );
$charge_duration = $calendar->hours_between( $date_due, $date_returned );
} else {
$charge_duration = $date_returned->delta_ms( $date_due );
$charge_duration = $date_returned->delta_ms($date_due);
}
if($charge_duration->in_units('hours') == 0 && $charge_duration->in_units('seconds') > 0){
if ( $charge_duration->in_units('hours') == 0 && $charge_duration->in_units('seconds') > 0 ) {
return 1;
}
return $charge_duration->in_units('hours');
}
else { # days
if(C4::Context->preference('finesCalendar') eq 'noFinesWhenClosed') {
} 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 );
} else {
$charge_duration = $date_returned->delta_days( $date_due );
$charge_duration = $date_returned->delta_days($date_due);
}
return $charge_duration->in_units('days');
}
}
=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(
@ -543,7 +544,7 @@ sub UpdateFine {
my $amount = $params->{amount};
my $due = $params->{due} // q{};
unless ( $issue_id ) {
unless ($issue_id) {
carp("No issue_id passed in!");
return;
}
@ -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' ) {
while ( my $overdue = $overdues->next ) {
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,18 +586,21 @@ 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;
}
}
if ( $accountline ) {
if ( Koha::Number::Price->new($accountline->amount)->round != Koha::Number::Price->new($amount)->round ) {
if ($accountline) {
if ( Koha::Number::Price->new( $accountline->amount )->round != Koha::Number::Price->new($amount)->round ) {
$accountline->adjust(
{
amount => $amount,
@ -602,9 +610,10 @@ 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(
if ($amount) { # Don't add new fines with an amount of 0
my $patron = Koha::Patrons->find($borrowernumber);
my $letter = eval {
C4::Letters::GetPreparedLetter(
module => 'circulation',
letter_code => 'OVERDUE_FINE_DESC',
message_transport_type => 'print',
@ -614,10 +623,11 @@ sub UpdateFine {
borrowers => $borrowernumber,
items => $itemnum,
},
) };
my $desc = $letter ? $letter->{content} : sprintf("Item %s - due %s", $itemnum, output_pref($due) );
);
};
my $desc = $letter ? $letter->{content} : sprintf( "Item %s - due %s", $itemnum, output_pref($due) );
my $account = Koha::Account->new({ patron_id => $borrowernumber });
my $account = Koha::Account->new( { patron_id => $borrowernumber } );
$accountline = $account->add_debit(
{
amount => $amount,
@ -655,15 +665,14 @@ 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;
}
my $sth = $dbh->prepare($query);
$sth->execute( @query_param );
$sth->execute(@query_param);
my $fine = $sth->fetchrow_hashref();
if ($fine->{fineamount}) {
if ( $fine->{fineamount} ) {
return $fine->{fineamount};
}
return 0;
@ -679,15 +688,18 @@ 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');
return Koha::Libraries->search( {}, { order_by => 'branchname' } )->get_column('branchcode');
}
return @$branchcodes;
}
@ -703,8 +715,8 @@ FIXME: This function should be renamed.
=cut
sub GetOverduesForBranch {
my ( $branch, $location) = @_;
my $itype_link = (C4::Context->preference('item-level_itypes')) ? " items.itype " : " biblioitems.itemtype ";
my ( $branch, $location ) = @_;
my $itype_link = ( C4::Context->preference('item-level_itypes') ) ? " items.itype " : " biblioitems.itemtype ";
my $dbh = C4::Context->dbh;
my $select = "
SELECT
@ -749,10 +761,10 @@ sub GetOverduesForBranch {
";
if ($location) {
my $q = "$select AND items.location = ? ORDER BY borrowers.surname, borrowers.firstname";
return @{ $dbh->selectall_arrayref($q, { Slice => {} }, $branch, $location ) };
return @{ $dbh->selectall_arrayref( $q, { Slice => {} }, $branch, $location ) };
} else {
my $q = "$select ORDER BY borrowers.surname, borrowers.firstname";
return @{ $dbh->selectall_arrayref($q, { Slice => {} }, $branch ) };
return @{ $dbh->selectall_arrayref( $q, { Slice => {} }, $branch ) };
}
}
@ -768,13 +780,13 @@ sub GetOverdueMessageTransportTypes {
my ( $branchcode, $categorycode, $letternumber ) = @_;
return unless $categorycode and $letternumber;
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("
my $sth = $dbh->prepare( "
SELECT message_transport_type
FROM overduerules odr LEFT JOIN overduerules_transport_types ott USING (overduerules_id)
WHERE branchcode = ?
AND categorycode = ?
AND letternumber = ?
");
" );
$sth->execute( $branchcode, $categorycode, $letternumber );
my @mtts;
while ( my $mtt = $sth->fetchrow ) {
@ -828,10 +840,11 @@ sub parse_overdues_letter {
my @item_tables;
if ( my $i = $params->{'items'} ) {
foreach my $item (@$i) {
my $fine = GetFine($item->{'itemnumber'}, $params->{'borrowernumber'});
$item->{'fine'} = currency_format($currency_format, "$fine", FMT_SYMBOL);
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'};
$item->{'fine'} = sprintf( '%.2f', $fine ) unless $item->{'fine'};
push @item_tables, {
'biblio' => $item->{'biblionumber'},
@ -842,7 +855,7 @@ sub parse_overdues_letter {
}
}
return C4::Letters::GetPreparedLetter (
return C4::Letters::GetPreparedLetter(
module => 'circulation',
letter_code => $params->{'letter_code'},
branchcode => $params->{'branchcode'},

2
C4/Patroncards.pm
View File

@ -25,7 +25,7 @@ BEGIN {
rm_image
text_alignment
unpack_UTF8
);
);
use C4::Patroncards::Patroncard;
use C4::Patroncards::Profile;
use C4::Patroncards::Template;

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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?
}

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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?
}

90
C4/Patroncards/Lib.pm
View File

@ -37,45 +37,43 @@ BEGIN {
sub unpack_UTF8 {
my ($str) = @_;
my @UTF8 = (unpack("U0U*", $str));
my @UTF8 = ( unpack( "U0U*", $str ) );
my @HEX = map { sprintf '%2.2x', $_ } @UTF8;
return \@HEX;
}
sub text_alignment {
my ($origin_llx, $text_box_width, $text_llx, $string_width, $line, $alignment) = @_;
my ( $origin_llx, $text_box_width, $text_llx, $string_width, $line, $alignment ) = @_;
my $Tw = 0;
my $Tx = 0;
if ($alignment eq 'J') {
if ( $alignment eq 'J' ) {
my $UTF82HEX = unpack_UTF8($line);
my $space_count = 0;
grep {$space_count++ if $_ eq '20'} @$UTF82HEX;
$Tw = (($text_box_width - $text_llx) - $string_width) / $space_count;
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') {
my $center_margin = ($text_box_width / 2) + ($origin_llx - $text_llx);
$Tx = $center_margin - ($string_width / 2);
} 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') {
$Tx = ($text_box_width - $string_width) + (($origin_llx - $text_llx) / 2);
} 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 {
my ($llx, $lly, $width, $height, $pdf) = @_;
my ( $llx, $lly, $width, $height, $pdf ) = @_;
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
@ -87,30 +85,31 @@ sub box {
}
sub get_borrower_attributes {
my ($borrower_number, @fields) = @_;
my ( $borrower_number, @fields ) = @_;
my $get_branch = 0;
$get_branch = 1 if grep{$_ eq 'branchcode'} @fields;
$get_branch = 1 if grep { $_ eq 'branchcode' } @fields;
my $attrib_count = scalar(@fields);
my $query = "SELECT ";
while (scalar(@fields)) {
while ( scalar(@fields) ) {
$query .= shift(@fields);
$query .= ', ' if scalar(@fields);
}
$query .= " FROM borrowers WHERE borrowernumber = ?";
my $sth = C4::Context->dbh->prepare($query);
# $sth->{'TraceLevel'} = 3;
# $sth->{'TraceLevel'} = 3;
$sth->execute($borrower_number);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
my $borrower_attributes = $sth->fetchrow_hashref();
if ($get_branch) {
$query = "SELECT branchname FROM branches WHERE branchcode = ?";
$sth = C4::Context->dbh->prepare($query);
$sth->execute($borrower_attributes->{'branchcode'});
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute( $borrower_attributes->{'branchcode'} );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
$borrower_attributes->{'branchcode'} = $sth->fetchrow_hashref()->{'branchname'};
@ -119,44 +118,44 @@ sub get_borrower_attributes {
}
sub put_image {
my ($image_name, $image_file) = @_;
if (my $image_limit = C4::Context->preference('ImageLimit')) { # enforce quota if set
my ( $image_name, $image_file ) = @_;
if ( my $image_limit = C4::Context->preference('ImageLimit') ) { # enforce quota if set
my $query = "SELECT count(*) FROM creator_images;";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute();
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
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) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
$sth->execute( $image_file, $image_name, $image_file );
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
return;
}
sub get_image {
my ($image_name, $fields) = @_;
my ( $image_name, $fields ) = @_;
$fields = '*' unless $fields;
my $query = "SELECT $fields FROM creator_images";
$query .= " WHERE image_name = ?" if $image_name;
my $sth = C4::Context->dbh->prepare($query);
if ($image_name) {
$sth->execute($image_name);
}
else {
} else {
$sth->execute();
}
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
return 1;
}
return $sth->fetchall_arrayref({});
return $sth->fetchall_arrayref( {} );
}
sub rm_image {
@ -166,15 +165,14 @@ sub rm_image {
my $query = "DELETE FROM creator_images WHERE image_id = ?";
my $sth = C4::Context->dbh->prepare($query);
$sth->execute($image_id);
if ($sth->err) {
warn sprintf('Database returned the following error: %s', $sth->errstr);
push (@$errstr, $image_id);
if ( $sth->err ) {
warn sprintf( 'Database returned the following error: %s', $sth->errstr );
push( @$errstr, $image_id );
}
}
if ($errstr) {
return $errstr;
}
else {
} else {
return;
}
}

188
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 );
@ -54,14 +55,14 @@ C4::Patroncards::Patroncard
=cut
sub new {
my ($invocant, %params) = @_;
my ( $invocant, %params ) = @_;
my $type = ref($invocant) || $invocant;
my $units = get_unit_values();
my $unitvalue = 1;
my $unitdesc = '';
foreach my $un (@$units){
if ($un->{'type'} eq $params{'layout'}->{'units'}) {
foreach my $un (@$units) {
if ( $un->{'type'} eq $params{'layout'}->{'units'} ) {
$unitvalue = $un->{'value'};
$unitdesc = $un->{'desc'};
}
@ -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'},
@ -82,7 +84,7 @@ sub new {
barcode_height_scale => $params{'layout'}->{'barcode'}[0]->{'height_scale'} || 0.01,
barcode_width_scale => $params{'layout'}->{'barcode'}[0]->{'width_scale'} || 0.8,
};
bless ($self, $type);
bless( $self, $type );
return $self;
}
@ -117,7 +119,7 @@ sub draw_barcode {
=cut
sub draw_guide_box {
my ($self, $pdf) = @_;
my ( $self, $pdf ) = @_;
warn sprintf('No pdf object passed in.') and return -1 if !$pdf;
my $obj_stream = "q\n"; # save the graphic state
@ -139,7 +141,7 @@ Adds a grid to the PDF output ($pdf) to support layout design
=cut
sub draw_guide_grid {
my ($self, $pdf) = @_;
my ( $self, $pdf ) = @_;
warn sprintf('No pdf object passed in.') and return -1 if !$pdf;
# Set up the grid in user defined units.
@ -150,10 +152,15 @@ 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++) {
my $xx = $x*$self->{'unitvalue'};
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) ) {
if ( ( $cnt % 10 ) && !( $cnt % 5 ) ) {
$obj_stream .= "0.0 1.0 0.0 RG\n";
$obj_stream .= "0 w\n";
} elsif ( $cnt % 5 ) {
@ -163,7 +170,7 @@ sub draw_guide_grid {
$obj_stream .= "0.0 0.0 1.0 RG\n";
$obj_stream .= "0 w\n";
}
$cnt ++;
$cnt++;
$obj_stream .= "$xx $y m\n";
$obj_stream .= "$xx $yy l\n";
@ -174,12 +181,17 @@ 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'};
my $yy = $y * $self->{'unitvalue'};
if ( ($cnt % 10) && ! ($cnt % 5) ) {
if ( ( $cnt % 10 ) && !( $cnt % 5 ) ) {
$obj_stream .= "0.0 1.0 0.0 RG\n";
$obj_stream .= "0 w\n";
} elsif ( $cnt % 5 ) {
@ -189,7 +201,7 @@ sub draw_guide_grid {
$obj_stream .= "0.0 0.0 1.0 RG\n";
$obj_stream .= "0 w\n";
}
$cnt ++;
$cnt++;
$obj_stream .= "$x $yy m\n";
$obj_stream .= "$xx $yy l\n";
@ -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 );
$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
@ -219,32 +235,32 @@ Draws text to PDF output ($pdf)
=cut
sub draw_text {
my ($self, $pdf, %params) = @_;
my ( $self, $pdf, %params ) = @_;
warn sprintf('No pdf object passed in.') and return -1 if !$pdf;
my @card_text = ();
return unless (ref($self->{'layout'}->{'text'}) eq 'ARRAY'); # just in case there is not text
return unless ( ref( $self->{'layout'}->{'text'} ) eq 'ARRAY' ); # just in case there is not text
my $text = [@{$self->{'layout'}->{'text'}}]; # make a copy of the arrayref *not* simply a pointer
while (scalar @$text) {
my $text = [ @{ $self->{'layout'}->{'text'} } ]; # make a copy of the arrayref *not* simply a pointer
while ( scalar @$text ) {
my $line = shift @$text;
my $parse_line = $line;
my @orig_line = split(/ /,$line);
if ($parse_line =~ m/<[A-Za-z0-9_]+>/) { # test to see if the line has db fields embedded...
my @orig_line = split( / /, $line );
if ( $parse_line =~ m/<[A-Za-z0-9_]+>/ ) { # test to see if the line has db fields embedded...
my @fields = ();
while ($parse_line =~ m/<([A-Za-z0-9_]+)>(.*$)/) {
push (@fields, $1);
while ( $parse_line =~ m/<([A-Za-z0-9_]+)>(.*$)/ ) {
push( @fields, $1 );
$parse_line = $2;
}
my $borrower_attributes = get_borrower_attributes($self->{'borrower_number'},@fields);
my $borrower_attributes = get_borrower_attributes( $self->{'borrower_number'}, @fields );
@orig_line = map { # substitute data for db fields
my $l = $_;
if ($l =~ m/<([A-Za-z0-9_]+)>/) {
if ( $l =~ m/<([A-Za-z0-9_]+)>/ ) {
my $field = $1;
$l =~ s/$l/$borrower_attributes->{$field}/;
}
$l;
} @orig_line;
$line = join(' ',@orig_line);
$line = join( ' ', @orig_line );
}
my $text_attribs = shift @$text;
my $llx = $self->{'llx'} || 0;
@ -257,17 +273,19 @@ 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
#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
#
# my $m = Font::TTFMetrics->new("/usr/share/fonts/truetype/msttcorefonts/Times_New_Roman_Bold.ttf");
# my $units_per_em = $m->get_units_per_em();
# my $font_units_width = $m->string_width($line);
# my $string_width = ($font_units_width * $text_attribs->{'font_size'}) / $units_per_em;
#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
#
# my $m = Font::TTFMetrics->new("/usr/share/fonts/truetype/msttcorefonts/Times_New_Roman_Bold.ttf");
# my $units_per_em = $m->get_units_per_em();
# my $font_units_width = $m->string_width($line);
# my $string_width = ($font_units_width * $text_attribs->{'font_size'}) / $units_per_em;
## Please see file perltidy.ERR
my $string_width = C4::Creators::PDF->StrWidth( $line, $text_attribs->{'font'}, $text_attribs->{'font_size'} );
if ( ( $string_width + $llx_text_attr ) > $self->{'width'} ) {
@ -309,10 +327,11 @@ sub draw_text {
$text_attribs->{'text_alignment'}
);
$line =~ s/^\s+//g; # strip naughty leading spaces
push @lines, {line=> $line, Tx => $Tx, Ty => $Ty, Tw => $Tw};
push @lines, { line => $line, Tx => $Tx, Ty => $Ty, Tw => $Tw };
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,31 +339,36 @@ 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};
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.
# 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.
if (0) {
my $box_height = 0;
my $box_lly = $origin_lly;
if (scalar(@lines) > 1) {
$box_height += scalar(@lines) * ($text_attribs->{'font_size'} * 1.2);
$box_lly -= ($text_attribs->{'font_size'} * 0.2);
}
else {
if ( scalar(@lines) > 1 ) {
$box_height += scalar(@lines) * ( $text_attribs->{'font_size'} * 1.2 );
$box_lly -= ( $text_attribs->{'font_size'} * 0.2 );
} 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'});
$pdf->Font( $text_attribs->{'font'} );
$pdf->FontSize( $text_attribs->{'font_size'} );
foreach my $line (@lines) {
$pdf->Text($line->{'Tx'}, $line->{'Ty'}, $line->{'line'});
$pdf->Text( $line->{'Tx'}, $line->{'Ty'}, $line->{'line'} );
}
}
}
@ -358,19 +382,25 @@ Draws images to PDF output ($pdf)
=cut
sub draw_image {
my ($self, $pdf) = @_;
my ( $self, $pdf ) = @_;
warn sprintf('No pdf object passed in.') and return -1 if !$pdf;
my $images = $self->{'layout'}->{'images'};
PROCESS_IMAGES:
foreach my $image (keys %$images) {
PROCESS_IMAGES:
foreach my $image ( keys %$images ) {
next PROCESS_IMAGES if $images->{$image}->{'data_source'}->[0]->{'image_source'} eq 'none';
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";
@ -391,21 +421,21 @@ sub _draw_barcode { # this is cut-and-paste from Label.pm because there is no
my %params = @_;
my $x_scale_factor = 1;
my $num_of_chars = length($params{'barcode_data'});
my $num_of_chars = length( $params{'barcode_data'} );
my $tot_bar_length = 0;
my $bar_length = 0;
my $guard_length = 10;
if ($params{'barcode_type'} =~ m/CODE39/) {
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
$x_scale_factor = ($params{'width'} / $tot_bar_length);
if ($params{'barcode_type'} eq 'CODE39MOD') {
$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') {
$params{'barcode_data'} = $c39->complete( $params{'barcode_data'} );
} elsif ( $params{'barcode_type'} eq 'CODE39MOD10' ) {
my $c39_10 = CheckDigits('siret'); # get modulo 10 checksum
$params{'barcode_data'} = $c39_10->complete($params{'barcode_data'});
$params{'barcode_data'} = $c39_10->complete( $params{'barcode_data'} );
}
eval {
PDF::Reuse::Barcode::Code39(
@ -420,13 +450,12 @@ 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'}, $@);
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;
$tot_bar_length = ( $bar_length * $num_of_chars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
eval {
PDF::Reuse::Barcode::COOP2of5(
x => $params{'llx'},
@ -438,13 +467,12 @@ 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'}, $@);
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;
$tot_bar_length = ( $bar_length * $num_of_chars ) + ( $guard_length * 2 );
$x_scale_factor = ( $params{'width'} / $tot_bar_length ) * 0.9;
eval {
PDF::Reuse::Barcode::Industrial2of5(
x => $params{'llx'},
@ -456,7 +484,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'}, $@);
warn sprintf( 'Barcode generation failed for item %s with this error: %s', $self->{'item_number'}, $@ );
}
}
}

6
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;
@ -30,12 +29,11 @@ sub retrieve {
}
sub delete {
if (ref($_[0])) {
if ( ref( $_[0] ) ) {
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::(.+)::.+$/;

311
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
@ -82,25 +81,27 @@ Returns an ISO-2709 scalar
=cut
sub marc2marc {
my ($marc,$to_flavour,$from_flavour,$encoding) = @_;
my ( $marc, $to_flavour, $from_flavour, $encoding ) = @_;
my $error;
if ($to_flavour && $to_flavour =~ m/marcstd/) {
if ( $to_flavour && $to_flavour =~ m/marcstd/ ) {
my $marc_record_obj;
if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
if ( $marc =~ /^MARC::Record/ ) { # it's already a MARC::Record object
$marc_record_obj = $marc;
} else { # it's not a MARC::Record object, make it one
eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
# conversion to MARC::Record object failed, populate $error
if ($@) { $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR };
# conversion to MARC::Record object failed, populate $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')) {
foreach my $field ( $marc_record_obj->fields() ) {
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'));
} elsif ( !( $field->is_control_field() ) ) {
$field->delete_subfield( code => '9' ) if ( $field->subfield('9') );
}
}
$marc_record_obj->delete_field($_) for @privatefields;
@ -109,7 +110,7 @@ sub marc2marc {
} else {
$error = "Feature not yet implemented\n";
}
return ($error,$marc);
return ( $error, $marc );
}
=head2 marc2marcxml - Convert from ISO-2709 to MARCXML
@ -129,41 +130,45 @@ C<$dont_entity_encode> - a flag that instructs marc2marcxml not to entity encode
=cut
sub marc2marcxml {
my ($marc,$encoding,$flavour,$dont_entity_encode) = @_;
my ( $marc, $encoding, $flavour, $dont_entity_encode ) = @_;
my $error; # the error string
my $marcxml; # the final MARCXML scalar
# test if it's already a MARC::Record object, if not, make it one
my $marc_record_obj;
if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
if ( $marc =~ /^MARC::Record/ ) { # it's already a MARC::Record object
$marc_record_obj = $marc;
} else { # it's not a MARC::Record object, make it one
eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
# conversion to MARC::Record object failed, populate $error
if ($@) { $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR };
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
# record creation failed, populate $error
if ($@) {
$error .= "Creation of MARCXML failed:".$MARC::File::ERROR;
$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,8 +192,9 @@ sub marc2marcxml {
}
}
}
# return result to calling program
return ($error,$marcxml);
return ( $error, $marcxml );
}
=head2 marcxml2marc - Convert from MARCXML to ISO-2709
@ -205,21 +212,25 @@ C<$flavour> - MARC21 or UNIMARC
=cut
sub marcxml2marc {
my ($marcxml,$encoding,$flavour) = @_;
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
eval { $marc = MARC::Record->new_from_xml( $marcxml, $encoding, $flavour ) }; # handle exceptions
# record creation failed, populate $error
if ($@) {$error .="\nCreation of MARCXML Record failed: ".$@;
$error.=$MARC::File::ERROR if ($MARC::File::ERROR);
};
if ($@) {
$error .= "\nCreation of MARCXML Record failed: " . $@;
$error .= $MARC::File::ERROR if ($MARC::File::ERROR);
}
# return result to calling program
return ($error,$marc);
return ( $error, $marc );
}
=head2 marc2dcxml - Convert from ISO-2709 to Dublin Core
@ -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 );
$marcxml = C4::Record::marc2marcxml($marc);
} elsif ( not defined $xml and defined $biblionumber ) {
# get MARCXML biblio directly without item information
$marcxml = C4::Biblio::GetXmlBiblio( $biblionumber );
$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')
@ -275,24 +292,24 @@ sub marc2dcxml {
};
# conversion to MARC::Record object failed
if ( $@ ) {
if ($@) {
croak "Creation of MARC::Record object failed.";
} elsif ( $record->warnings() ) {
carp "Warnings encountered while processing ISO-2709 record.\n";
my @warnings = $record->warnings();
foreach my $warn (@warnings) {
carp "\t". $warn;
};
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 ) {
if ($err) {
croak "Error $err while processing\n";
} else {
return $output;
@ -310,7 +327,7 @@ Returns a MODS scalar
sub marc2modsxml {
my ($marc) = @_;
return _transformWithStylesheet($marc, "/prog/en/xslt/MARC21slim2MODS3-1.xsl");
return _transformWithStylesheet( $marc, "/prog/en/xslt/MARC21slim2MODS3-1.xsl" );
}
=head2 marc2madsxml - Convert from ISO-2709 to MADS
@ -323,7 +340,7 @@ Returns a MADS scalar
sub marc2madsxml {
my ($marc) = @_;
return _transformWithStylesheet($marc, "/prog/en/xslt/MARC21slim2MADS.xsl");
return _transformWithStylesheet( $marc, "/prog/en/xslt/MARC21slim2MADS.xsl" );
}
=head2 _transformWithStylesheet - Transform a MARC record with a stylesheet
@ -336,11 +353,12 @@ contain the path to a stylesheet under intrahtdocs.
=cut
sub _transformWithStylesheet {
my ($marc, $stylesheet) = @_;
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;
return C4::XSLT::engine->transform($xmlrecord, $xslfile);
return C4::XSLT::engine->transform( $xmlrecord, $xslfile );
}
sub marc2endnote {
@ -370,14 +388,14 @@ sub marc2endnote {
};
my $style = Biblio::EndnoteStyle->new();
my $template;
$template.= "DB - DB\n" if C4::Context->preference("LibraryName");
$template.="T1 - Title\n" if $marc_rec_obj->title();
$template.="A1 - Author\n" if $marc_rec_obj->author();
$template.="PB - Publisher\n" if $f710a;
$template.="CY - City\n" if $f260a;
$template.="Y1 - Year\n" if $marc_rec_obj->publication_date;
$template.="AB - Abstract\n" if $abstract;
my ($text, $errmsg) = $style->format($template, $fields);
$template .= "DB - DB\n" if C4::Context->preference("LibraryName");
$template .= "T1 - Title\n" if $marc_rec_obj->title();
$template .= "A1 - Author\n" if $marc_rec_obj->author();
$template .= "PB - Publisher\n" if $f710a;
$template .= "CY - City\n" if $f260a;
$template .= "Y1 - Year\n" if $marc_rec_obj->publication_date;
$template .= "AB - Abstract\n" if $abstract;
my ( $text, $errmsg ) = $style->format( $template, $fields );
return ($text);
}
@ -399,25 +417,25 @@ C<$itemnumbers> - a list of itemnumbers to export
=cut
sub marc2csv {
my ($biblios, $id, $itemnumbers) = @_;
my ( $biblios, $id, $itemnumbers ) = @_;
$itemnumbers ||= [];
my $output;
my $csv = Text::CSV::Encoded->new( { formula => "empty" } );
# Getting yaml file
my $configfile = "../tools/csv-profiles/$id.yaml";
my ($preprocess, $postprocess, $fieldprocessing);
if (-e $configfile){
($preprocess,$postprocess, $fieldprocessing) = YAML::XS::LoadFile($configfile);
my ( $preprocess, $postprocess, $fieldprocessing );
if ( -e $configfile ) {
( $preprocess, $postprocess, $fieldprocessing ) = YAML::XS::LoadFile($configfile);
}
# Preprocessing
eval $preprocess if ($preprocess); ## no critic (StringyEval)
my $firstpass = 1;
if ( @$itemnumbers ) {
for my $itemnumber ( @$itemnumbers) {
my $item = Koha::Items->find( $itemnumber );
if (@$itemnumbers) {
for my $itemnumber (@$itemnumbers) {
my $item = Koha::Items->find($itemnumber);
my $biblionumber = $item->biblio->biblionumber;
$output .= marcrecord2csv( $biblionumber, $id, $firstpass, $csv, $fieldprocessing, [$itemnumber] ) // '';
$firstpass = 0;
@ -456,7 +474,7 @@ C<$itemnumbers> a list of itemnumbers to export
=cut
sub marcrecord2csv {
my ($biblionumber, $id, $header, $csv, $fieldprocessing, $itemnumbers) = @_;
my ( $biblionumber, $id, $header, $csv, $fieldprocessing, $itemnumbers ) = @_;
my $output;
# Getting the record
@ -473,33 +491,35 @@ sub marcrecord2csv {
# Getting output encoding
my $encoding = $profile->encoding || 'utf8';
# Getting separators
my $csvseparator = $profile->csv_separator || ',';
my $fieldseparator = $profile->field_separator || '#';
my $subfieldseparator = $profile->subfield_separator || '|';
# TODO: Be more generic (in case we have to handle other protected chars or more separators)
if ($csvseparator eq '\t') { $csvseparator = "\t" }
if ($fieldseparator eq '\t') { $fieldseparator = "\t" }
if ($subfieldseparator eq '\t') { $subfieldseparator = "\t" }
if ($csvseparator eq '\n') { $csvseparator = "\n" }
if ($fieldseparator eq '\n') { $fieldseparator = "\n" }
if ($subfieldseparator eq '\n') { $subfieldseparator = "\n" }
if ( $csvseparator eq '\t' ) { $csvseparator = "\t" }
if ( $fieldseparator eq '\t' ) { $fieldseparator = "\t" }
if ( $subfieldseparator eq '\t' ) { $subfieldseparator = "\t" }
if ( $csvseparator eq '\n' ) { $csvseparator = "\n" }
if ( $fieldseparator eq '\n' ) { $fieldseparator = "\n" }
if ( $subfieldseparator eq '\n' ) { $subfieldseparator = "\n" }
$csv = $csv->encoding_out($encoding) ;
$csv = $csv->encoding_out($encoding);
$csv->sep_char($csvseparator);
# Getting the marcfields
my $marcfieldslist = $profile->content;
# Getting the marcfields as an array
my @marcfieldsarray = split('\|', $marcfieldslist);
my @marcfieldsarray = split( '\|', $marcfieldslist );
# Separating the marcfields from the user-supplied headers
my @csv_structures;
foreach (@marcfieldsarray) {
my @result = split('=', $_, 2);
my $content = ( @result == 2 )
my @result = split( '=', $_, 2 );
my $content =
( @result == 2 )
? $result[1]
: $result[0];
my @fields;
@ -508,10 +528,10 @@ sub marcrecord2csv {
my $subfieldtag = $2;
push @fields, { fieldtag => $fieldtag, subfieldtag => $subfieldtag };
}
if ( @result == 2) {
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,8 +553,9 @@ 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;
push @{ $field_list->{fields}{ 0 + $fieldtag } }, $values;
}
# For each field or subfield
@ -543,14 +564,16 @@ sub marcrecord2csv {
my $tags = $csv_structure->{fields};
my $content = $csv_structure->{content};
if ( $header ) {
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} ) {
if ( defined $tag->{subfieldtag} ) {
my $query = "SELECT liblibrarian FROM marc_subfield_structure WHERE tagfield=? AND tagsubfield=?";
my @results = $dbh->selectrow_array( $query, {}, $tag->{fieldtag}, $tag->{subfieldtag} );
push @marcfieldsheaders, $results[0];
@ -564,43 +587,53 @@ 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;
my $tt_output = process_tt( $content, $field_list );
push @csv_rows, $tt_output;
} else {
for my $tag ( @$tags ) {
for my $tag (@$tags) {
my @fields = $record->field( $tag->{fieldtag} );
# If it is a subfield
my @loop_values;
if (defined $tag->{subfieldtag} ) {
if ( defined $tag->{subfieldtag} ) {
my $av_description_mapping = Koha::AuthorisedValues->get_descriptions_by_marc_field(
{
frameworkcode => $frameworkcode, tagfield => $tag->{fieldtag},
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;
}
}
# Or a field
} else {
foreach my $field ( @fields ) {
foreach my $field (@fields) {
my $value;
# If it is a control field
if ($field->is_control_field) {
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,9 +644,14 @@ 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);
$value = join( $subfieldseparator, @subvaluesarray );
}
# Field processing
@ -631,7 +669,7 @@ sub marcrecord2csv {
values => \@loop_values,
};
}
for my $field_value ( @field_values ) {
for my $field_value (@field_values) {
if ( $field_value->{subfieldtag} ) {
push @csv_rows, join( $subfieldseparator, @{ $field_value->{values} } );
} else {
@ -641,8 +679,7 @@ sub marcrecord2csv {
}
}
if ( $header ) {
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);
@ -679,34 +715,35 @@ FIXME: shouldn't have to convert to and from xml/marc just to change encoding so
=cut
sub changeEncoding {
my ($record,$format,$flavour,$to_encoding,$from_encoding) = @_;
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 ( lc($format) =~ /^marc$/o ) {
# if we're converting encoding of an ISO2709 file, we need to roundtrip through XML
# because MARC::Record doesn't directly provide us with an encoding method
# It's definitely less than idea and should be fixed eventually - kados
my $marcxml; # temporary storage of MARCXML scalar
($error,$marcxml) = marc2marcxml($record,$to_encoding,$flavour);
( $error, $marcxml ) = marc2marcxml( $record, $to_encoding, $flavour );
unless ($error) {
($error,$newrecord) = marcxml2marc($marcxml,$to_encoding,$flavour);
( $error, $newrecord ) = marcxml2marc( $marcxml, $to_encoding, $flavour );
}
# MARCXML Record
} elsif (lc($format) =~ /^marcxml$/o) { # MARCXML Record
} elsif ( lc($format) =~ /^marcxml$/o ) { # MARCXML Record
my $marc;
($error,$marc) = marcxml2marc($record,$to_encoding,$flavour);
( $error, $marc ) = marcxml2marc( $record, $to_encoding, $flavour );
unless ($error) {
($error,$newrecord) = marc2marcxml($record,$to_encoding,$flavour);
( $error, $newrecord ) = marc2marcxml( $record, $to_encoding, $flavour );
}
} else {
$error.="Unsupported record format:".$format;
$error .= "Unsupported record format:" . $format;
}
return ($error,$newrecord);
return ( $error, $newrecord );
}
=head2 marc2bibtex - Convert from MARC21 and UNIMARC to BibTex
@ -721,26 +758,26 @@ C<$id> - an id for the BibTex record (might be the biblionumber)
=cut
sub marc2bibtex {
my ($record, $id) = @_;
my ( $record, $id ) = @_;
my $tex;
my $marcflavour = C4::Context->preference("marcflavour");
# Authors
my $author;
my @texauthors;
my @authorFields = ('100','110','111','700','710','711');
@authorFields = ('700','701','702','710','711','721') if ( $marcflavour eq "UNIMARC" );
my @authorFields = ( '100', '110', '111', '700', '710', '711' );
@authorFields = ( '700', '701', '702', '710', '711', '721' ) if ( $marcflavour eq "UNIMARC" );
foreach my $field (@authorFields) {
foreach my $field ( @authorFields ) {
# author formatted surname, firstname
my $texauthor = '';
if ( $marcflavour eq "UNIMARC" ) {
$texauthor = join ', ',
( $record->subfield($field,"a"), $record->subfield($field,"b") );
( $record->subfield( $field, "a" ), $record->subfield( $field, "b" ) );
} else {
$texauthor = $record->subfield($field,"a");
$texauthor = $record->subfield( $field, "a" );
}
push @texauthors, $texauthor if $texauthor;
}
@ -758,18 +795,18 @@ sub marc2bibtex {
# Mandatory
author => $author,
title => $record->subfield("200", "a") || "",
editor => $record->subfield("210", "g") || "",
publisher => $record->subfield("210", "c") || "",
year => $record->subfield("210", "d") || $record->subfield("210", "h") || "",
title => $record->subfield( "200", "a" ) || "",
editor => $record->subfield( "210", "g" ) || "",
publisher => $record->subfield( "210", "c" ) || "",
year => $record->subfield( "210", "d" ) || $record->subfield( "210", "h" ) || "",
# Optional
volume => $record->subfield("200", "v") || "",
series => $record->subfield("225", "a") || "",
address => $record->subfield("210", "a") || "",
edition => $record->subfield("205", "a") || "",
note => $record->subfield("300", "a") || "",
url => $record->subfield("856", "u") || ""
volume => $record->subfield( "200", "v" ) || "",
series => $record->subfield( "225", "a" ) || "",
address => $record->subfield( "210", "a" ) || "",
edition => $record->subfield( "205", "a" ) || "",
note => $record->subfield( "300", "a" ) || "",
url => $record->subfield( "856", "u" ) || ""
);
} else {
@ -778,18 +815,21 @@ sub marc2bibtex {
# Mandatory
author => $author,
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") || "",
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" )
|| "",
# Optional
# unimarc to marc21 specification says not to convert 200$v to marc21
series => $record->subfield("490", "a") || "",
address => $record->subfield("264", "a") || $record->subfield("260", "a") || "",
edition => $record->subfield("250", "a") || "",
note => $record->subfield("500", "a") || "",
url => $record->subfield("856", "u") || ""
series => $record->subfield( "490", "a" ) || "",
address => $record->subfield( "264", "a" ) || $record->subfield( "260", "a" ) || "",
edition => $record->subfield( "250", "a" ) || "",
note => $record->subfield( "500", "a" ) || "",
url => $record->subfield( "856", "u" ) || ""
);
}
@ -797,25 +837,23 @@ sub marc2bibtex {
if ( $additional_fields && $additional_fields->{'@'} ) {
my ( $f, $sf ) = split( /\$/, $additional_fields->{'@'} );
my ( $type ) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
my ($type) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
if ($type) {
$tex .= '@' . $type . '{';
}
else {
} else {
$tex .= "\@book{";
}
}
else {
} else {
$tex .= "\@book{";
}
my @elt;
for ( my $i = 0 ; $i < scalar( @bh ) ; $i = $i + 2 ) {
next unless $bh[$i+1];
for ( my $i = 0 ; $i < scalar(@bh) ; $i = $i + 2 ) {
next unless $bh[ $i + 1 ];
push @elt, qq|\t$bh[$i] = {$bh[$i+1]}|;
}
$tex .= join(",\n", $id, @elt);
$tex .= join( ",\n", $id, @elt );
if ($additional_fields) {
$tex .= ",\n";
@ -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

9
C4/Reports.pm
View File

@ -22,7 +22,8 @@ use CGI qw ( -utf8 );
use C4::Context;
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -52,15 +53,15 @@ This will return a list of all the available delimiters.
sub GetDelimiterChoices {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare("
my $sth = $dbh->prepare( "
SELECT options, value
FROM systempreferences
WHERE variable = 'CSVDelimiter'
");
" );
$sth->execute();
my ($choices, $default) = $sth->fetchrow;
my ( $choices, $default ) = $sth->fetchrow;
my @dels = split /\|/, $choices;
return {

304
C4/Reports/Guided.pm
View File

@ -39,7 +39,8 @@ use Koha::Reports;
use Koha::SharedContent;
use Koha::TemplateUtils qw( process_tt );
our (@ISA, @EXPORT_OK);
our ( @ISA, @EXPORT_OK );
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@ -82,17 +83,15 @@ This will return a list of all the available report areas
sub get_area_name_sql_snippet {
my @REPORT_AREA = (
[CIRC => "Circulation"],
[CAT => "Catalogue"],
[PAT => "Patrons"],
[ACQ => "Acquisition"],
[ACC => "Accounts"],
[SER => "Serials"],
[ CIRC => "Circulation" ],
[ CAT => "Catalogue" ],
[ PAT => "Patrons" ],
[ ACQ => "Acquisition" ],
[ ACC => "Accounts" ],
[ 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,21 +149,23 @@ 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}
or warn( qq{REPORT_SUBGROUP "$sg" without REPORT_GROUP (lib_opac)} ),
or warn(qq{REPORT_SUBGROUP "$sg" without REPORT_GROUP (lib_opac)}),
next;
my $g_sg = $groups_with_subgroups{$g}
or warn( qq{REPORT_SUBGROUP "$sg" with invalid REPORT_GROUP "$g"} ),
or warn(qq{REPORT_SUBGROUP "$sg" with invalid REPORT_GROUP "$g"}),
next;
$g_sg->{subgroups}{$sg} = $_->{lib};
}
return \%groups_with_subgroups
return \%groups_with_subgroups;
}
=head2 get_all_tables
@ -236,39 +240,48 @@ 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);
}
sub _build_query {
my ( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition) = @_;
my ( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition ) = @_;
### $orderby
# $keys is an array of joining constraints
my $dbh = C4::Context->dbh();
my $joinedtables = join( ',', @$tables );
my $joinedcolumns = join( ',', @$columns );
my $query =
"SELECT $totals $joinedcolumns FROM $tables->[0] ";
for (my $i=1;$i<@$tables;$i++){
my $query = "SELECT $totals $joinedcolumns FROM $tables->[0] ";
for ( my $i = 1 ; $i < @$tables ; $i++ ) {
$query .= "LEFT JOIN $tables->[$i] on ($keys->[$i-1]) ";
}
@ -276,17 +289,16 @@ sub _build_query {
$criteria =~ s/AND/WHERE/;
$query .= " $criteria";
}
if ($definition){
my @definitions = split(',',$definition);
if ($definition) {
my @definitions = split( ',', $definition );
my $deftext;
foreach my $def (@definitions){
my $defin=get_from_dictionary('',$def);
$deftext .=" ".$defin->[0]->{'saved_sql'};
foreach my $def (@definitions) {
my $defin = get_from_dictionary( '', $def );
$deftext .= " " . $defin->[0]->{'saved_sql'};
}
if ($query =~ /WHERE/i){
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";
}
}
@ -319,24 +330,31 @@ Returns an arraref to hashrefs suitable for using in a tmpl_loop. With the crite
=cut
sub get_criteria {
my ($area,$cgi) = @_;
my ( $area, $cgi ) = @_;
my $dbh = C4::Context->dbh();
# 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;
@ -356,7 +373,7 @@ sub get_criteria {
my ( $value, $type ) = split( /\|/, $localcrit );
my ( $table, $column ) = split( /\./, $value );
my $description = $columns->{$table}->{$column};
if ($type eq 'textrange') {
if ( $type eq 'textrange' ) {
my %temp;
$temp{'name'} = $value;
$temp{'from'} = "from_" . $value;
@ -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,26 +395,26 @@ 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';
$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" : '' ) . ">>",
display_value => "<<$column" . ( $list ? "|$list" : '' ) . ">>",
};
while ( my $row = $sth->fetchrow_hashref() ) {
if ($row->{'availablevalues'} eq '') { $row->{'default'} = 1 }
if ( $row->{'availablevalues'} eq '' ) { $row->{'default'} = 1 }
else { $row->{display_value} = _get_display_value( $row->{'availablevalues'}, $column ); }
push @values, $row;
}
@ -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,9 +466,10 @@ 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)) {
while ( my $rows = $sth->fetchall_arrayref( undef, 1000 ) ) {
$n += @$rows;
}
return $n;
@ -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;
@ -504,19 +523,19 @@ sub strip_limit {
my ($sql) = @_;
return unless $sql;
return ($sql, 0, undef) unless $sql =~ /\bLIMIT\b/i;
return ( $sql, 0, undef ) unless $sql =~ /\bLIMIT\b/i;
# Two options: if there's no WHERE clause in the SQL, we simply capture
# any LIMIT that's there. If there is a WHERE, we make sure that we only
# capture a LIMIT after the last one. This prevents stomping on subqueries.
if ($sql !~ /\bWHERE\b/i) {
(my $res = $sql) =~ s/\bLIMIT\b\s*(\d+)(\s*\,\s*(\d+))?\s*/ /ig;
return ($res, (defined $2 ? $1 : 0), (defined $3 ? $3 : $1));
if ( $sql !~ /\bWHERE\b/i ) {
( my $res = $sql ) =~ s/\bLIMIT\b\s*(\d+)(\s*\,\s*(\d+))?\s*/ /ig;
return ( $res, ( defined $2 ? $1 : 0 ), ( defined $3 ? $3 : $1 ) );
} else {
my $res = $sql;
$res =~ m/.*\bWHERE\b/gsi;
$res =~ s/\G(.*)\bLIMIT\b\s*(\d+)(\s*\,\s*(\d+))?\s*/$1 /is;
return ($res, (defined $3 ? $2 : 0), (defined $4 ? $4 : $2));
return ( $res, ( defined $3 ? $2 : 0 ), ( defined $4 ? $4 : $2 ) );
}
}
@ -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,7 +712,8 @@ sub update_sql {
$report->cache_expiry($cache_expiry) if defined $cache_expiry;
$report->public($public);
$report->store();
if( $cache_expiry >= 2592000 ){
if ( $cache_expiry >= 2592000 ) {
die "Please specify a cache expiry less than 30 days\n"; # That's a bit harsh
}
@ -700,24 +723,28 @@ 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 ($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,
results => from_json( $json ),
results => from_json($json),
date_run => $date_run,
};
}
@ -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,28 +777,29 @@ EOQ
}
sub get_saved_reports {
# $filter is either { date => $d, author => $a, keyword => $kw, }
# or $keyword. Optional.
# $filter is either { date => $d, author => $a, keyword => $kw, }
# or $keyword. Optional.
my ($filter) = @_;
$filter = { keyword => $filter } if $filter && !ref( $filter );
my ($group, $subgroup) = @_;
$filter = { keyword => $filter } if $filter && !ref($filter);
my ( $group, $subgroup ) = @_;
my $dbh = C4::Context->dbh();
my $query = get_saved_reports_base_query;
my (@cond,@args);
my ( @cond, @args );
if ($filter) {
if (my $date = $filter->{date}) {
if ( my $date = $filter->{date} ) {
push @cond, "DATE(last_modified) = ? OR
DATE(last_run) = ?";
push @args, $date, $date;
}
if (my $author = $filter->{author}) {
if ( my $author = $filter->{author} ) {
$author = "%$author%";
push @cond, "surname LIKE ? OR
firstname LIKE ?";
push @args, $author, $author;
}
if (my $keyword = $filter->{keyword}) {
if ( my $keyword = $filter->{keyword} ) {
push @cond, q|
report LIKE ?
OR report_name LIKE ?
@ -780,20 +809,21 @@ sub get_saved_reports {
|;
push @args, "%$keyword%", "%$keyword%", "%$keyword%", "%$keyword%", $keyword;
}
if ($filter->{group}) {
if ( $filter->{group} ) {
push @cond, "report_group = ?";
push @args, $filter->{group};
}
if ($filter->{subgroup}) {
if ( $filter->{subgroup} ) {
push @cond, "report_subgroup = ?";
push @args, $filter->{subgroup};
}
}
$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 .= " 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 .= " ORDER by date_created";
my $result = $dbh->selectall_arrayref($query, {Slice => {}}, @args);
my $result = $dbh->selectall_arrayref( $query, { Slice => {} }, @args );
return $result;
}
@ -807,18 +837,19 @@ This takes a column name of the format table.column and will return what type it
sub get_column_type {
my ($tablecolumn) = @_;
my ($table,$column) = split(/\./,$tablecolumn);
my ( $table, $column ) = split( /\./, $tablecolumn );
my $dbh = C4::Context->dbh();
my $catalog;
my $schema;
# mysql doesn't support a column selection, set column to %
my $tempcolumn='%';
my $tempcolumn = '%';
my $sth = $dbh->column_info( $catalog, $schema, $table, $tempcolumn ) || die $dbh->errstr;
while (my $info = $sth->fetchrow_hashref()){
if ($info->{'COLUMN_NAME'} eq $column){
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'){
if ( $info->{'TYPE_NAME'} eq 'CHAR' || $info->{'TYPE_NAME'} eq 'VARCHAR' ) {
$info->{'TYPE_NAME'} = 'distinct';
}
return $info->{'TYPE_NAME'};
@ -835,13 +866,12 @@ with the distinct values of the column
sub get_distinct_values {
my ($tablecolumn) = @_;
my ($table,$column) = split(/\./,$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({});
return $sth->fetchall_arrayref( {} );
}
sub save_dictionary {
@ -850,7 +880,7 @@ sub save_dictionary {
my $query = "INSERT INTO reports_dictionary (name,description,saved_sql,report_area,date_created,date_modified)
VALUES (?,?,?,?,now(),now())";
my $sth = $dbh->prepare($query);
$sth->execute($name,$description,$sql,$area) || return 0;
$sth->execute( $name, $description, $sql, $area ) || return 0;
return 1;
}
@ -904,18 +934,20 @@ sub get_sql {
my $query = "SELECT * FROM saved_sql WHERE id = ?";
my $sth = $dbh->prepare($query);
$sth->execute($id);
my $data=$sth->fetchrow_hashref();
my $data = $sth->fetchrow_hashref();
return $data->{'savedsql'};
}
sub get_results {
my ( $report_id ) = @_;
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;
}
@ -975,12 +1009,12 @@ Returns an arrayref of hashes containing the keys name and authval
sub GetParametersFromSQL {
my $sql = shift ;
my @split = split(/<<|>>/,$sql);
my $sql = shift;
my @split = split( /<<|>>/, $sql );
my @sql_parameters = ();
for ( my $i = 0; $i < ($#split/2) ; $i++ ) {
my ($name,$authval) = split(/\|/,$split[$i*2+1]);
for ( my $i = 0 ; $i < ( $#split / 2 ) ; $i++ ) {
my ( $name, $authval ) = split( /\|/, $split[ $i * 2 + 1 ] );
$authval =~ s/\:all$|\:in$// if $authval;
push @sql_parameters, { 'name' => $name, 'authval' => $authval };
}
@ -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'} );
}
}
@ -1035,25 +1069,27 @@ sub EmailReport {
my @errors = ();
my @emails = ();
return ( undef, [{ FATAL => "MISSING_PARAMS" }] ) unless ($report_id && $module && $code);
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'};
my $report = Koha::Reports->find( $report_id );
my $report = Koha::Reports->find($report_id);
my $sql = $report->savedsql;
return ( { FATAL => "NO_REPORT" } ) unless $sql;
#don't pass offset or limit, hardcoded limit of 999,999 will be used
my ( $sth, $errors ) = execute_query( { sql => $sql, report_id => $report_id } );
return ( undef, [{ FATAL => "REPORT_FAIL" }] ) if $errors;
return ( undef, [ { FATAL => "REPORT_FAIL" } ] ) if $errors;
my $counter = 1;
my $template = $letter->{content};
@ -1061,24 +1097,25 @@ sub EmailReport {
while ( my $row = $sth->fetchrow_hashref() ) {
my $email;
my $err_count = scalar @errors;
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_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} } );
my $from_address = $from || $row->{from};
my $to_address = $row->{$email_col};
push ( @errors, { NOT_PARSE => $counter } ) unless my $content = process_tt( $template, $row );
push( @errors, { NOT_PARSE => $counter } ) unless my $content = process_tt( $template, $row );
$counter++;
next if scalar @errors > $err_count; #If any problems, try next
$letter->{content} = $content;
$email->{borrowernumber} = $row->{borrowernumber};
$email->{letter} = { %$letter };
$email->{letter} = {%$letter};
$email->{from_address} = $from_address;
$email->{to_address} = $to_address;
push ( @emails, $email );
push( @emails, $email );
}
return ( \@emails, \@errors );
@ -1097,7 +1134,6 @@ sub _get_display_value {
return $original_value;
}
=head3 convert_sql
my $updated_sql = C4::Reports::Guided::convert_sql( $sql );
@ -1108,7 +1144,7 @@ biblio_metadata.metadata field instead
=cut
sub convert_sql {
my ( $sql ) = @_;
my ($sql) = @_;
my $updated_sql = $sql;
if ( $sql =~ m|biblioitems| and $sql =~ m|marcxml| ) {
$updated_sql =~ s|biblioitems|biblio_metadata|g;

585
C4/Reserves.pm
View File

File diff suppressed because it is too large Load Diff

520
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
@ -99,7 +97,7 @@ sub marc2ris {
open my $oldout, qw{>&}, "STDOUT";
my $outvar;
close STDOUT;
open STDOUT,'>:encoding(utf8)', \$outvar;
open STDOUT, '>:encoding(utf8)', \$outvar;
## First we should check the character encoding. This may be
## MARC-8 or UTF-8. The former is indicated by a blank, the latter
@ -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;
}
}
@ -121,36 +118,33 @@ sub marc2ris {
## start RIS dataset
if ( $ris_additional_fields && $ris_additional_fields->{TY} ) {
my ( $f, $sf ) = split( /\$/, $ris_additional_fields->{TY} );
my ( $type ) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
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);
}
## retrieve all author fields and collect them in a list
my @author_fields;
if ($intype eq "unimarc") {
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
@author_fields = ( $record->field('700'), $record->field('701'), $record->field('702') );
} 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'));
@author_fields = ( $record->field('100'), $record->field('700') );
}
## loop over all author fields
foreach my $field (@author_fields) {
if (length($field)) {
if ( length($field) ) {
my $author = &get_author($field);
print "AU - ",$author,"\r\n";
print "AU - ", $author, "\r\n";
}
}
@ -160,97 +154,97 @@ sub marc2ris {
## add corporate names or meeting names as editors ??
my @editor_fields;
if ($intype eq "unimarc") {
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
@editor_fields = ($record->field('110'), $record->field('111'), $record->field('710'), $record->field('711'));
@editor_fields = ( $record->field('110'), $record->field('111'), $record->field('710'), $record->field('711') );
}
## loop over all editor fields
foreach my $field (@editor_fields) {
if (length($field)) {
if ( length($field) ) {
my $editor = &get_editor($field);
print "ED - ",$editor,"\r\n";
print "ED - ", $editor, "\r\n";
}
}
## get info from the title field
if ($intype eq "unimarc") {
&print_title($record->field('200'));
}
else { ## marc21, ukmarc
&print_title($record->field('245'));
if ( $intype eq "unimarc" ) {
&print_title( $record->field('200') );
} else { ## marc21, ukmarc
&print_title( $record->field('245') );
}
## series title
if ($intype eq "unimarc") {
&print_stitle($record->field('225'));
}
else { ## marc21, ukmarc
&print_stitle($record->field('490'));
if ( $intype eq "unimarc" ) {
&print_stitle( $record->field('225') );
} else { ## marc21, ukmarc
&print_stitle( $record->field('490') );
}
## ISBN/ISSN
if ($intype eq "unimarc") {
&print_isbn($record->field('010'));
&print_issn($record->field('011'));
}
elsif ($intype eq "ukmarc") {
&print_isbn($record->field('021'));
if ( $intype eq "unimarc" ) {
&print_isbn( $record->field('010') );
&print_issn( $record->field('011') );
} elsif ( $intype eq "ukmarc" ) {
&print_isbn( $record->field('021') );
## this is just an assumption
&print_issn($record->field('022'));
}
else { ## assume marc21
&print_isbn($record->field('020'));
&print_issn($record->field('022'));
&print_issn( $record->field('022') );
} else { ## assume marc21
&print_isbn( $record->field('020') );
&print_issn( $record->field('022') );
}
if ($intype eq "marc21") {
&print_loc_callno($record->field('050'));
&print_dewey($record->field('082'));
if ( $intype eq "marc21" ) {
&print_loc_callno( $record->field('050') );
&print_dewey( $record->field('082') );
}
## else: unimarc, ukmarc do not seem to store call numbers?
## publication info
if ($intype eq "unimarc") {
&print_pubinfo($record->field('210'));
}
else { ## marc21, ukmarc
if ($record->field('264')) {
&print_pubinfo($record->field('264'));
}
else {
&print_pubinfo($record->field('260'));
if ( $intype eq "unimarc" ) {
&print_pubinfo( $record->field('210') );
} else { ## marc21, ukmarc
if ( $record->field('264') ) {
&print_pubinfo( $record->field('264') );
} else {
&print_pubinfo( $record->field('260') );
}
}
## 6XX fields contain KW candidates. We add all of them to a
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');
} elsif ($intype eq "ukmarc") {
@field_list = ('600', '610', '611', '630', '650', '651','653', '655', '660', '661', '668', '690', '691', '692', '695');
if ( $intype eq "unimarc" ) {
@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' );
} else { ## assume marc21
@field_list = ('600', '610', '611', '630', '650', '651','653', '654', '655', '656', '657', '658');
@field_list = ( '600', '610', '611', '630', '650', '651', '653', '654', '655', '656', '657', '658' );
}
my @kwpool;
for my $f ( @field_list ) {
for my $f (@field_list) {
my @fields = $record->field($f);
push @kwpool, ( get_keywords("$f",$record->field($f)) );
push @kwpool, ( get_keywords( "$f", $record->field($f) ) );
}
# Remove duplicate
@kwpool = uniq @kwpool;
for my $kw ( @kwpool ) {
for my $kw (@kwpool) {
print "KW - ", $kw, "\r\n";
}
@ -259,42 +253,52 @@ sub marc2ris {
my @notepool;
## 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') {
&pool_subx(\@notepool, $_, $record->field($_));
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'
)
{
&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'
)
{
&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') {
&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') {
&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'
)
{
&pool_subx( \@notepool, $_, $record->field($_) );
}
}
my $allnotes = join "; ", @notepool;
if (length($allnotes) > 0) {
if ( length($allnotes) > 0 ) {
print "N1 - ", $allnotes, "\r\n";
}
## 320/520 have the abstract
if ($intype eq "unimarc") {
&print_abstract($record->field('320'));
}
elsif ($intype eq "ukmarc") {
&print_abstract($record->field('512'), $record->field('513'));
}
else { ## assume marc21
&print_abstract($record->field('520'));
if ( $intype eq "unimarc" ) {
&print_abstract( $record->field('320') );
} elsif ( $intype eq "ukmarc" ) {
&print_abstract( $record->field('512'), $record->field('513') );
} else { ## assume marc21
&print_abstract( $record->field('520') );
}
# 856u has the URI
if ($record->field('856')) {
print_uri($record->field('856'));
if ( $record->field('856') ) {
print_uri( $record->field('856') );
}
if ($ris_additional_fields) {
@ -327,7 +331,6 @@ sub marc2ris {
}
##********************************************************************
## print_typetag(): prints the first line of a RIS dataset including
## the preceding newline
@ -335,7 +338,7 @@ sub marc2ris {
## Returns: the value at leader position 06
##********************************************************************
sub print_typetag {
my ($leader)= @_;
my ($leader) = @_;
## the keys of typehash are the allowed values at position 06
## of the leader of a MARC record, the values are the RIS types
## that might appropriately represent these types.
@ -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
@ -385,16 +386,15 @@ sub print_typetag {
my %typehash;
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if ($intype eq "unimarc") {
if ( $intype eq "unimarc" ) {
%typehash = %unitypehash;
}
else {
} else {
%typehash = %ustypehash;
}
if (!defined $typeofrecord || !exists $typehash{$typeofrecord}) {
if ( !defined $typeofrecord || !exists $typehash{$typeofrecord} ) {
print "TY - GEN\r\n"; ## most reasonable default
warn ("no type found - assume GEN") if $marcprint;
warn("no type found - assume GEN") if $marcprint;
} elsif ( $typeofrecord =~ "a" ) {
if ( $biblevel eq 'a' ) {
print "TY - GEN\r\n"; ## monographic component part
@ -427,14 +427,14 @@ sub print_typetag {
## Returns: the normalized authorname
##********************************************************************
sub normalize_author {
my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
my ( $rawauthora, $rawauthorb, $rawauthorc, $nametype ) = @_;
if ( $nametype == 0 ) {
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;
@ -450,14 +450,12 @@ sub normalize_author {
$rawauthorb =~ s% *[,;:/]*$%%;
## we currently ignore subfield c until someone complains
if (length($rawauthorb) > 0) {
return join ", ", ($rawauthora, $rawauthorb);
}
else {
if ( length($rawauthorb) > 0 ) {
return join ", ", ( $rawauthora, $rawauthorb );
} else {
return $rawauthora;
}
}
elsif ($nametype == 3) {
} elsif ( $nametype == 3 ) {
return $rawauthora;
}
}
@ -475,24 +473,28 @@ sub get_author {
## 1 (marc21) or 2 (unimarc)
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if ($intype eq "unimarc") {
if ( $intype eq "unimarc" ) {
$indicator = 2;
}
else { ## assume marc21
} else { ## assume marc21
$indicator = 1;
}
print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\r\n" if $marcprint;
print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\r\n" if $marcprint;
print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\r\n" if $marcprint;
print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\r\n" if $marcprint;
print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\r\n" if $marcprint;
if ($intype eq "ukmarc") {
print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"), "\r\n" if $marcprint;
print "<marc>:Author(\$a): ", $authorfield->subfield('a'), "\r\n" if $marcprint;
print "<marc>:Author(\$b): ", $authorfield->subfield('b'), "\r\n" if $marcprint;
print "<marc>:Author(\$c): ", $authorfield->subfield('c'), "\r\n" if $marcprint;
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")
);
}
}
@ -504,13 +506,12 @@ sub get_author {
sub get_editor {
my ($editorfield) = @_;
if (!$editorfield) {
if ( !$editorfield ) {
return;
}
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;
} 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;
return $editorfield->subfield('a');
}
}
@ -522,14 +523,13 @@ sub get_editor {
##********************************************************************
sub print_title {
my ($titlefield) = @_;
if (!$titlefield) {
if ( !$titlefield ) {
print "<marc>empty title field (245)\r\n" if $marcprint;
warn("empty title field (245)") if $marcprint;
}
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;
} 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;
## The title is usually written in a very odd notation. The title
## proper ($a) often ends with a space followed by a separator like
@ -541,19 +541,20 @@ sub print_title {
my $clean_title = $titlefield->subfield('a');
my $clean_subtitle = $titlefield->subfield('b');
$clean_subtitle ||= q{};
$clean_subtitle ||= q{};
$clean_title =~ s% *[/:;.]$%%;
$clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if (length($clean_title) > 0
|| (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
if ( length($clean_title) > 0
|| ( length($clean_subtitle) > 0 && $intype ne "unimarc" ) )
{
print "TI - ", $clean_title;
## subfield $b is relevant only for marc21/ukmarc
if (length($clean_subtitle) > 0 && $intype ne "unimarc") {
print ": ",$clean_subtitle;
if ( length($clean_subtitle) > 0 && $intype ne "unimarc" ) {
print ": ", $clean_subtitle;
}
print "\r\n";
}
@ -574,25 +575,24 @@ $clean_subtitle ||= q{};
sub print_stitle {
my ($titlefield) = @_;
if (!$titlefield) {
if ( !$titlefield ) {
print "<marc>empty series title field\r\n" if $marcprint;
}
else {
print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
} else {
print "<marc>Series title(\$a): ", $titlefield->subfield('a'), "\r\n" if $marcprint;
my $clean_title = $titlefield->subfield('a');
$clean_title =~ s% *[/:;.]$%%;
if (length($clean_title) > 0) {
print "T2 - ", $clean_title,"\r\n";
if ( length($clean_title) > 0 ) {
print "T2 - ", $clean_title, "\r\n";
}
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if ($intype eq "unimarc") {
print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\r\n" if $marcprint;
if (length($titlefield->subfield('v')) > 0) {
print "VL - ", $titlefield->subfield('v'),"\r\n";
if ( $intype eq "unimarc" ) {
print "<marc>Series vol(\$v): ", $titlefield->subfield('v'), "\r\n" if $marcprint;
if ( length( $titlefield->subfield('v') ) > 0 ) {
print "VL - ", $titlefield->subfield('v'), "\r\n";
}
}
}
@ -604,14 +604,13 @@ sub print_stitle {
## Arguments: field (020)
##********************************************************************
sub print_isbn {
my($isbnfield) = @_;
my ($isbnfield) = @_;
if (!$isbnfield || length ($isbnfield->subfield('a')) == 0) {
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 {
if (length ($isbnfield->subfield('a')) < 10) {
} else {
if ( length( $isbnfield->subfield('a') ) < 10 ) {
print "<marc>truncated isbn (020\$a)\r\n" if $marcprint;
warn("truncated isbn") if $marcprint;
}
@ -626,19 +625,18 @@ sub print_isbn {
## Arguments: field (022)
##********************************************************************
sub print_issn {
my($issnfield) = @_;
my ($issnfield) = @_;
if (!$issnfield || length ($issnfield->subfield('a')) == 0) {
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 {
if (length ($issnfield->subfield('a')) < 9) {
} else {
if ( length( $issnfield->subfield('a') ) < 9 ) {
print "<marc>truncated issn (022\$a)\r\n" if $marcprint;
warn("truncated issn") if $marcprint;
}
my $issn = substr($issnfield->subfield('a'), 0, 9);
my $issn = substr( $issnfield->subfield('a'), 0, 9 );
print "SN - ", $issn, "\r\n";
}
}
@ -650,7 +648,7 @@ sub print_uri {
my @f856s = @_;
foreach my $f856 (@f856s) {
if (my $uri = $f856->subfield('u')) {
if ( my $uri = $f856->subfield('u') ) {
print "UR - ", $uri, "\r\n";
}
}
@ -661,13 +659,12 @@ sub print_uri {
## Arguments: field (050)
##********************************************************************
sub print_loc_callno {
my($callnofield) = @_;
my ($callnofield) = @_;
if (!$callnofield || length ($callnofield->subfield('a')) == 0) {
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";
}
}
@ -677,13 +674,12 @@ sub print_loc_callno {
## Arguments: field (082)
##********************************************************************
sub print_dewey {
my($deweyfield) = @_;
my ($deweyfield) = @_;
if (!$deweyfield || length ($deweyfield->subfield('a')) == 0) {
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";
}
}
@ -693,13 +689,12 @@ sub print_dewey {
## Arguments: field (260)
##********************************************************************
sub print_pubinfo {
my($pubinfofield) = @_;
my ($pubinfofield) = @_;
if (!$pubinfofield) {
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
@ -727,12 +722,11 @@ sub print_pubinfo {
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);
if ($intype eq "unimarc") {
if ( $intype eq "unimarc" ) {
$pubsub_place = "a";
$pubsub_publisher = "c";
$pubsub_date = "d";
}
else { ## assume marc21
} else { ## assume marc21
$pubsub_place = "a";
$pubsub_publisher = "b";
$pubsub_date = "c";
@ -741,21 +735,19 @@ sub print_pubinfo {
## loop over all subfield list entries
for my $tuple (@pubsubfields) {
## each tuple consists of the subfield code and the value
if (@$tuple[0] eq $pubsub_place) {
if ( @$tuple[0] eq $pubsub_place ) {
## strip any trailing crap
$_ = @$tuple[1];
s% *[,;:/]$%%;
## pool all occurrences in a list
push (@cities, $_);
}
elsif (@$tuple[0] eq $pubsub_publisher) {
push( @cities, $_ );
} 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) {
push( @publishers, $_ );
} 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"
@ -774,23 +766,21 @@ sub print_pubinfo {
## year, make it up. If digits are replaced by '-',
## replace those with 0s
if (index($protoyear, "/") == 4) {
if ( index( $protoyear, "/" ) == 4 ) {
## have year info
## replace all '-' in the four-digit year
## by '0'
substr($protoyear,0,4) =~ s!-!0!g;
}
else {
substr( $protoyear, 0, 4 ) =~ s!-!0!g;
} else {
## have no year info
print "<marc>no four-digit year found, use 0000\r\n" if $marcprint;
$protoyear = "0000///$protoyear";
warn("no four-digit year found, use 0000") if $marcprint;
}
if ($pycounter == 0 && length($protoyear)) {
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
@ -799,11 +789,11 @@ sub print_pubinfo {
}
## now dump the collected CY and PB lists
if (@cities > 0) {
print "CY - ", join(", ", @cities), "\r\n";
if ( @cities > 0 ) {
print "CY - ", join( ", ", @cities ), "\r\n";
}
if (@publishers > 0) {
print "PB - ", join(", ", @publishers), "\r\n";
if ( @publishers > 0 ) {
print "PB - ", join( ", ", @publishers ), "\r\n";
}
}
}
@ -813,22 +803,30 @@ sub print_pubinfo {
## Arguments: list of fields (6XX)
##********************************************************************
sub get_keywords {
my($fieldname, @keywords) = @_;
my ( $fieldname, @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 ) {
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'));
if ( $fieldname eq "600" ) {
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();
@ -837,10 +835,10 @@ sub get_keywords {
## loop over all subfields to check
foreach my $subfield (@subfields) {
## [0] contains subfield code
if (@$kwtuple[0] eq $subfield) {
if ( @$kwtuple[0] eq $subfield ) {
## [1] contains value, remove trailing separators
@$kwtuple[1] =~ s% *[,;.:/]*$%%;
if (length(@$kwtuple[1]) > 0) {
if ( length( @$kwtuple[1] ) > 0 ) {
push @kw, @$kwtuple[1];
print "<marc>Field $fieldname subfield $subfield:", @$kwtuple[1], "\r\n" if $marcprint;
}
@ -862,89 +860,66 @@ sub get_keywords {
## list of fields (5XX)
##********************************************************************
sub pool_subx {
my($aref, $fieldname, @notefields) = @_;
my ( $aref, $fieldname, @notefields ) = @_;
## we use a list that contains the interesting subfields
## for each field
# ToDo: this is apparently correct only for marc21
my @subfields;
if ($fieldname eq "500") {
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") {
@subfields = ('a', 'b');
}
elsif ($fieldname eq "505") {
@subfields = ('a', 'g', 'r', 't', 'u');
}
elsif ($fieldname eq "506") {
@subfields = ('a', 'b', 'c', 'd', 'e');
}
elsif ($fieldname eq "507") {
@subfields = ('a', 'b');
}
elsif ($fieldname eq "508") {
} elsif ( $fieldname eq "504" ) {
@subfields = ( 'a', 'b' );
} elsif ( $fieldname eq "505" ) {
@subfields = ( 'a', 'g', 'r', 't', 'u' );
} elsif ( $fieldname eq "506" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e' );
} elsif ( $fieldname eq "507" ) {
@subfields = ( 'a', 'b' );
} elsif ( $fieldname eq "508" ) {
@subfields = ('a');
}
elsif ($fieldname eq "510") {
@subfields = ('a', 'b', 'c', 'x', '3');
}
elsif ($fieldname eq "511") {
} elsif ( $fieldname eq "510" ) {
@subfields = ( 'a', 'b', 'c', 'x', '3' );
} elsif ( $fieldname eq "511" ) {
@subfields = ('a');
}
elsif ($fieldname eq "513") {
@subfields = ('a', 'b');
}
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 "513" ) {
@subfields = ( 'a', 'b' );
} elsif ( $fieldname eq "514" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z' );
} elsif ( $fieldname eq "515" ) {
@subfields = ('a');
}
elsif ($fieldname eq "516") {
} elsif ( $fieldname eq "516" ) {
@subfields = ('a');
}
elsif ($fieldname eq "518") {
@subfields = ('a', '3');
}
elsif ($fieldname eq "521") {
@subfields = ('a', 'b', '3');
}
elsif ($fieldname eq "522") {
} elsif ( $fieldname eq "518" ) {
@subfields = ( 'a', '3' );
} elsif ( $fieldname eq "521" ) {
@subfields = ( 'a', 'b', '3' );
} elsif ( $fieldname eq "522" ) {
@subfields = ('a');
}
elsif ($fieldname eq "524") {
@subfields = ('a', '2', '3');
}
elsif ($fieldname eq "525") {
} elsif ( $fieldname eq "524" ) {
@subfields = ( 'a', '2', '3' );
} elsif ( $fieldname eq "525" ) {
@subfields = ('a');
}
elsif ($fieldname eq "526") {
@subfields = ('a', 'b', 'c', 'd', 'i', 'x', 'z', '5');
}
elsif ($fieldname eq "530") {
@subfields = ('a', 'b', 'c', 'd', 'u', '3');
}
elsif ($fieldname eq "533") {
@subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3');
}
elsif ($fieldname eq "534") {
@subfields = ('a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z');
}
elsif ($fieldname eq "535") {
@subfields = ('a', 'b', 'c', 'd', 'g', '3');
} elsif ( $fieldname eq "526" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'i', 'x', 'z', '5' );
} elsif ( $fieldname eq "530" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'u', '3' );
} elsif ( $fieldname eq "533" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3' );
} elsif ( $fieldname eq "534" ) {
@subfields = ( 'a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z' );
} elsif ( $fieldname eq "535" ) {
@subfields = ( 'a', 'b', 'c', 'd', 'g', '3' );
}
## loop over all notefields
foreach my $notefield (@notefields) {
if (defined $notefield) {
if ( defined $notefield ) {
## retrieve all available subfield tuples
my @notesubfields = $notefield->subfields();
@ -953,11 +928,11 @@ sub pool_subx {
## loop over all subfields to check
foreach my $subfield (@subfields) {
## [0] contains subfield code
if (@$notetuple[0] eq $subfield) {
if ( @$notetuple[0] eq $subfield ) {
## [1] contains value, remove trailing separators
print "<marc>field $fieldname subfield $subfield: ", @$notetuple[1], "\r\n" if $marcprint;
@$notetuple[1] =~ s% *[,;.:/]*$%%;
if (length(@$notetuple[1]) > 0) {
if ( length( @$notetuple[1] ) > 0 ) {
## add to list
push @{$aref}, @$notetuple[1];
}
@ -974,11 +949,12 @@ sub pool_subx {
## Arguments: list of fields (520)
##********************************************************************
sub print_abstract {
# ToDo: take care of repeatable subfields
my(@abfields) = @_;
my (@abfields) = @_;
## we check the following subfields
my @subfields = ('a', 'b');
my @subfields = ( 'a', 'b' );
## we generate a list for all useful strings
my @abstrings;
@ -1002,7 +978,7 @@ sub print_abstract {
my $allabs = join "; ", @abstrings;
if (length($allabs) > 0) {
if ( length($allabs) > 0 ) {
print "N2 - ", $allabs, "\r\n";
}

53
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
@ -83,12 +82,12 @@ sub CreateCollection {
my ( $title, $description ) = @_;
my $schema = Koha::Database->new()->schema();
my $duplicate_titles = $schema->resultset('Collection')->count({ colTitle => $title });
my $duplicate_titles = $schema->resultset('Collection')->count( { colTitle => $title } );
## Check for all necessary parameters
if ( !$title ) {
return ( 0, 1, "NO_TITLE" );
} elsif ( $duplicate_titles ) {
} elsif ($duplicate_titles) {
return ( 0, 2, "DUPLICATE_TITLE" );
}
@ -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 ) {
@ -140,7 +140,7 @@ sub UpdateCollection {
if ( !$title ) {
return ( 0, 2, "NO_TITLE" );
}
if ( $duplicate_titles ) {
if ($duplicate_titles) {
return ( 0, 3, "DUPLICATE_TITLE" );
}
@ -335,20 +335,19 @@ sub AddItemToCollection {
if ( isItemInThisCollection( $itemnumber, $colId ) ) {
return ( 0, 2, "IN_COLLECTION" );
}
elsif ( isItemInAnyCollection($itemnumber) ) {
} elsif ( isItemInAnyCollection($itemnumber) ) {
return ( 0, 3, "IN_COLLECTION_OTHER" );
}
my $dbh = C4::Context->dbh;
my $sth;
$sth = $dbh->prepare("
$sth = $dbh->prepare( "
INSERT INTO collections_tracking (
colId,
itemnumber
) VALUES ( ?, ? )
");
" );
$sth->execute( $colId, $itemnumber ) or return ( 0, 3, $sth->errstr() );
return 1;
@ -417,10 +416,10 @@ sub TransferCollection {
## Check for all necessary parameters
if ( !$colId ) {
return ( 0, [{ type => 'error', code => 'NO_ID' }] );
return ( 0, [ { type => 'error', code => 'NO_ID' } ] );
}
if ( !$colBranchcode ) {
return ( 0, [{ type => 'error', code => 'NO_BRANCHCODE' }] );
return ( 0, [ { type => 'error', code => 'NO_BRANCHCODE' } ] );
}
my $dbh = C4::Context->dbh;
@ -433,15 +432,17 @@ sub TransferCollection {
WHERE colId = ?"
);
$sth->execute( $colBranchcode, $colId ) or return 0;
my $to_library = Koha::Libraries->find( $colBranchcode );
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,22 +492,20 @@ 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();
}
};
}
return (1, $messages);
return ( 1, $messages );
}
=head2 GetCollectionItemBranches
@ -528,7 +525,7 @@ sub GetCollectionItemBranches {
my ( $sth, @results );
$sth = $dbh->prepare(
"SELECT holdingbranch, colBranchcode FROM items, collections, collections_tracking
"SELECT holdingbranch, colBranchcode FROM items, collections, collections_tracking
WHERE items.itemnumber = collections_tracking.itemnumber
AND collections.colId = collections_tracking.colId
AND items.itemnumber = ?"
@ -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;
}
}

261
C4/SIP/ILS.pm
View File

@ -48,10 +48,10 @@ my %supports = (
);
sub new {
my ($class, $institution) = @_;
my ( $class, $institution ) = @_;
my $type = ref($class) || $class;
my $self = {};
siplog("LOG_DEBUG", "new ILS '%s'", $institution->{id});
siplog( "LOG_DEBUG", "new ILS '%s'", $institution->{id} );
$self->{institution} = $institution;
return bless $self, $type;
}
@ -77,46 +77,54 @@ sub institution_id {
}
sub supports {
my ($self, $op) = @_;
return (exists($supports{$op}) && $supports{$op});
my ( $self, $op ) = @_;
return ( exists( $supports{$op} ) && $supports{$op} );
}
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});
my ( $self, $id, $whence ) = @_;
if ( $id ne $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
($bool =~ /true|y|yes/i) and return 1; # true
return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
( $bool =~ /true|y|yes/i ) and return 1; # true
return ( $bool =~ /^\d+$/ and $bool != 0 ); # true for non-zero numbers, false otherwise
}
sub checkout_ok {
my $self = shift;
return (exists($self->{institution}->{policy}->{checkout})
&& to_bool($self->{institution}->{policy}->{checkout}));
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}));
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}));
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})
&& to_bool($self->{institution}->{policy}->{offline}));
return ( exists( $self->{institution}->{policy}->{offline} )
&& to_bool( $self->{institution}->{policy}->{offline} ) );
}
#
@ -131,10 +139,11 @@ sub checkout {
my ( $self, $patron_id, $item_id, $sc_renew, $fee_ack, $account, $no_block_due_date ) = @_;
my ( $patron, $item, $circ );
my @blocked_item_types;
if (defined $account->{blocked_item_types}) {
if ( defined $account->{blocked_item_types} ) {
@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 ) {
if ($patron->debarred) {
} 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 }));
} elsif ($patron->fine_blocked) {
} elsif ( $patron->expired ) {
$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} });
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);
@ -216,10 +221,9 @@ sub checkout {
siplog(
"LOG_DEBUG", "ILS::Checkout: patron %s has checked out %s",
$patron_id, join( ', ', map{ $_->{barcode} } @{ $patron->{items} } )
$patron_id, join( ', ', map { $_->{barcode} } @{ $patron->{items} } )
);
}
else {
} else {
siplog( "LOG_ERR", "ILS::Checkout Issue failed" );
}
}
@ -230,7 +234,8 @@ sub checkout {
}
sub _ci_cardnumber_cmp {
my ( $s1, $s2) = @_;
my ( $s1, $s2 ) = @_;
# As the database is case insensitive we need to normalize two strings
# before comparing them
return ( uc($s1) eq uc($s2) );
@ -239,8 +244,8 @@ sub _ci_cardnumber_cmp {
# wrapper which allows above to be called for testing
sub test_cardnumber_compare {
my ($self, $str1, $str2) = @_;
return _ci_cardnumber_cmp($str1, $str2);
my ( $self, $str1, $str2 ) = @_;
return _ci_cardnumber_cmp( $str1, $str2 );
}
sub checkin {
@ -260,11 +265,10 @@ 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 );
$circ->ok(0);
$circ->screen_msg('Invalid Item');
return $circ;
}
@ -274,20 +278,20 @@ sub checkin {
siplog( "LOG_WARNING", "Problem with issue_id in issues and old_issues; check the about page" );
} elsif ( $data->{messages}->{ResFound} && !$circ->ok && $holds_block_checkin ) {
$circ->screen_msg("Item is on hold, please return to circulation desk");
siplog ("LOG_DEBUG", "C4::SIP::ILS::Checkin - item on hold");
siplog( "LOG_DEBUG", "C4::SIP::ILS::Checkin - item on hold" );
} elsif ( $data->{messages}->{withdrawn} && !$circ->ok && C4::Context->preference("BlockReturnOfWithdrawnItems") ) {
$circ->screen_msg("Item withdrawn, return not allowed");
siplog ("LOG_DEBUG", "C4::SIP::ILS::Checkin - item withdrawn");
siplog( "LOG_DEBUG", "C4::SIP::ILS::Checkin - item withdrawn" );
} elsif ( $data->{messages}->{WasLost} && !$circ->ok && C4::Context->preference("BlockReturnOfLostItems") ) {
$circ->screen_msg("Item lost, return not allowed");
siplog("LOG_DEBUG", "C4::SIP::ILS::Checkin - item lost");
siplog( "LOG_DEBUG", "C4::SIP::ILS::Checkin - item lost" );
} elsif ( !$item->{borrowernumber} ) {
if ( $checked_in_ok ) { # Mark checkin ok although book not checked out
$circ->ok( 1 );
siplog("LOG_DEBUG", "C4::SIP::ILS::Checkin - using checked_in_ok");
if ($checked_in_ok) { # Mark checkin ok although book not checked out
$circ->ok(1);
siplog( "LOG_DEBUG", "C4::SIP::ILS::Checkin - using checked_in_ok" );
} else {
$circ->screen_msg("Item not checked out");
siplog("LOG_DEBUG", "C4::SIP::ILS::Checkin - item not checked out");
siplog( "LOG_DEBUG", "C4::SIP::ILS::Checkin - item not checked out" );
}
} elsif ( $circ->ok ) {
$circ->patron( $patron = C4::SIP::ILS::Patron->new( { borrowernumber => $item->{borrowernumber} } ) );
@ -307,19 +311,22 @@ sub checkin {
}
# Check for overdue fines to display
if ($account->{show_outstanding_amount}) {
if ( $account->{show_outstanding_amount} ) {
my $kohaitem = Koha::Items->find( { barcode => $item_id } );
if ($kohaitem) {
my $charges = Koha::Account::Lines->search(
{
borrowernumber => $patron->{borrowernumber},
amountoutstanding => { '>' => 0 },
debit_type_code => [ 'OVERDUE' ],
debit_type_code => ['OVERDUE'],
itemnumber => $kohaitem->itemnumber
},
);
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.
@ -340,27 +348,31 @@ sub checkin {
# If the ILS caches patron information, this lets it free
# it up
sub end_patron_session {
my ($self, $patron_id) = @_;
my ( $self, $patron_id ) = @_;
# success?, screen_msg, print_line
return (1, 'Thank you!', '');
return ( 1, 'Thank you!', '' );
}
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();
$trans->transaction_id($trans_id);
my $patron;
$trans->patron($patron = C4::SIP::ILS::Patron->new($patron_id));
if (!$patron) {
$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,19 +384,21 @@ 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 ($patron, $item);
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();
$patron = C4::SIP::ILS::Patron->new( $patron_id );
$patron = C4::SIP::ILS::Patron->new($patron_id);
if ( !$patron ) {
$trans->screen_msg("Invalid patron barcode.");
return $trans;
}
unless ($item = C4::SIP::ILS::Item->new($item_id || $title_id)) {
unless ( $item = C4::SIP::ILS::Item->new( $item_id || $title_id ) ) {
$trans->screen_msg("No such item.");
return $trans;
}
@ -393,7 +407,7 @@ sub add_hold {
$trans->screen_msg("Excessive fees blocking placement of hold.");
}
if ($item->fee and $fee_ack ne 'Y') {
if ( $item->fee and $fee_ack ne 'Y' ) {
$trans->screen_msg = "Fee required to place hold.";
return $trans;
}
@ -412,25 +426,25 @@ sub add_hold {
$trans->pickup_location($pickup_location);
$trans->do_hold;
push(@{$item->hold_queue}, $hold);
push(@{$patron->{hold_items}}, $hold);
push( @{ $item->hold_queue }, $hold );
push( @{ $patron->{hold_items} }, $hold );
return $trans;
}
sub cancel_hold {
my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
my ($patron, $item, $hold);
my ( $self, $patron_id, $patron_pwd, $item_id, $title_id ) = @_;
my ( $patron, $item, $hold );
my $trans = C4::SIP::ILS::Transaction::Hold->new();
$patron = C4::SIP::ILS::Patron->new( $patron_id );
if (!$patron) {
$patron = C4::SIP::ILS::Patron->new($patron_id);
if ( !$patron ) {
$trans->screen_msg("Invalid patron barcode.");
return $trans;
}
unless ($item = C4::SIP::ILS::Item->new($item_id || $title_id)) {
unless ( $item = C4::SIP::ILS::Item->new( $item_id || $title_id ) ) {
$trans->screen_msg("No such item.");
return $trans;
}
@ -438,20 +452,22 @@ sub cancel_hold {
$trans->patron($patron);
$trans->item($item);
$trans->drop_hold;
unless ($trans->ok) {
$trans->screen_msg("Error with transaction drop_hold: " . $trans->screen_msg);
unless ( $trans->ok ) {
$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!
# Now, remove it from the item record. If it was on the patron
# record but not on the item record, we'll treat that as success.
foreach my $i (0 .. scalar @{$item->hold_queue}) {
foreach my $i ( 0 .. scalar @{ $item->hold_queue } ) {
$hold = $item->hold_queue->[$i];
if ($item->barcode_is_borrowernumber($patron->id, $hold->{borrowernumber})) {
if ( $item->barcode_is_borrowernumber( $patron->id, $hold->{borrowernumber} ) ) {
# found it: delete it.
splice @{$item->hold_queue}, $i, 1;
splice @{ $item->hold_queue }, $i, 1;
last; # ?? should we keep going, in case there are multiples
}
}
@ -461,38 +477,41 @@ 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 ($patron, $item);
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;
$trans = C4::SIP::ILS::Transaction::Hold->new();
# BEGIN TRANSACTION
$patron = C4::SIP::ILS::Patron->new( $patron_id );
$patron = C4::SIP::ILS::Patron->new($patron_id);
unless ($patron) {
$trans->screen_msg("Invalid patron barcode: '$patron_id'.");
return $trans;
}
foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
foreach my $i ( 0 .. scalar @{ $patron->{hold_items} } ) {
$hold = $patron->{hold_items}[$i];
if ($hold->{item_id} eq $item_id) {
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);
$trans->item(C4::SIP::ILS::Item->new( $hold->{item_id}));
$trans->item( C4::SIP::ILS::Item->new( $hold->{item_id} ) );
last;
}
}
@ -502,7 +521,7 @@ sub alter_hold {
# for the item, so we don't need to search the hold queue for
# the item, since it's already been updated by the patron code.
if (!$trans->ok) {
if ( !$trans->ok ) {
$trans->screen_msg("No such outstanding hold.");
}
@ -510,18 +529,20 @@ 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) = @_;
my ($patron, $item);
$item_props, $fee_ack
) = @_;
my ( $patron, $item );
my $trans;
$trans = C4::SIP::ILS::Transaction::Renew->new();
$trans->patron($patron = C4::SIP::ILS::Patron->new( $patron_id ));
if (!$patron) {
$trans->patron( $patron = C4::SIP::ILS::Patron->new($patron_id) );
if ( !$patron ) {
$trans->screen_msg("Invalid patron barcode.");
return $trans;
} elsif (!$patron->renew_ok) {
} elsif ( !$patron->renew_ok ) {
$trans->screen_msg("Renewals not allowed.");
return $trans;
}
@ -537,19 +558,21 @@ sub renew {
# }
# } else {
my $j = 0;
my $count = scalar @{$patron->{items}};
foreach my $i (@{$patron->{items}}) {
unless (defined $i->{barcode}) { # FIXME: using data instead of objects may violate the abstraction layer
siplog("LOG_ERR", "No barcode for item %s of %s: $item_id", $j+1, $count);
my $count = scalar @{ $patron->{items} };
foreach my $i ( @{ $patron->{items} } ) {
unless ( defined $i->{barcode} ) { # FIXME: using data instead of objects may violate the abstraction layer
siplog( "LOG_ERR", "No barcode for item %s of %s: $item_id", $j + 1, $count );
next;
}
siplog("LOG_DEBUG", "checking item %s of %s: $item_id vs. %s", ++$j, $count, $i->{barcode});
if ($i->{barcode} eq $item_id) {
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 );
$item = C4::SIP::ILS::Item->new($item_id);
last;
}
}
# }
$trans->item($item);
@ -557,12 +580,12 @@ sub renew {
$trans->fee_ack($fee_ack);
}
if (!defined($item)) {
$trans->screen_msg("Item not checked out to " . $patron->name); # not checked out to $patron_id
if ( !defined($item) ) {
$trans->screen_msg( "Item not checked out to " . $patron->name ); # not checked out to $patron_id
$trans->ok(0);
} else {
$trans->do_renew();
if ($trans->renewal_ok()) {
if ( $trans->renewal_ok() ) {
$item->{due_date} = $trans->{due};
$trans->desensitize(0);
}
@ -572,8 +595,8 @@ sub renew {
}
sub renew_all {
my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
my ($patron, $item_id);
my ( $self, $patron_id, $patron_pwd, $fee_ack ) = @_;
my ( $patron, $item_id );
my $trans;
$trans = C4::SIP::ILS::Transaction::RenewAll->new();
@ -581,17 +604,17 @@ sub renew_all {
$trans->fee_ack($fee_ack);
}
$trans->patron($patron = C4::SIP::ILS::Patron->new( $patron_id ));
if (defined $patron) {
siplog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s", $patron->name, $patron->renew_ok);
$trans->patron( $patron = C4::SIP::ILS::Patron->new($patron_id) );
if ( defined $patron ) {
siplog( "LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s", $patron->name, $patron->renew_ok );
} else {
siplog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'", $patron_id);
siplog( "LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'", $patron_id );
}
if (!$patron) {
if ( !$patron ) {
$trans->screen_msg("Invalid patron barcode.");
return $trans;
} elsif (!$patron->renew_ok) {
} elsif ( !$patron->renew_ok ) {
$trans->screen_msg("Renewals not allowed.");
return $trans;
}

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

@ -73,18 +73,18 @@ use Koha::TemplateUtils qw( process_tt );
=cut
sub new {
my ($class, $item_id) = @_;
my ( $class, $item_id ) = @_;
my $type = ref($class) || $class;
my $item = Koha::Items->find( { barcode => barcodedecode( $item_id ) } );
unless ( $item ) {
siplog("LOG_DEBUG", "new ILS::Item('%s'): not found", $item_id);
my $item = Koha::Items->find( { barcode => barcodedecode($item_id) } );
unless ($item) {
siplog( "LOG_DEBUG", "new ILS::Item('%s'): not found", $item_id );
warn "new ILS::Item($item_id) : No item '$item_id'.";
return;
}
my $self = $item->unblessed;
$self->{_object} = $item;
$self->{id} = $item->barcode; # to SIP, the barcode IS the id.
if (C4::Context->preference('UseLocationAsAQInSIP')) {
if ( C4::Context->preference('UseLocationAsAQInSIP') ) {
$self->{permanent_location} = $item->permanent_location;
} else {
$self->{permanent_location} = $item->homebranch;
@ -98,7 +98,7 @@ sub new {
my $it = $item->effective_itemtype;
$self->{itemtype} = $it;
my $itemtype = Koha::Database->new()->schema()->resultset('Itemtype')->find( $it );
my $itemtype = Koha::Database->new()->schema()->resultset('Itemtype')->find($it);
$self->{sip_media_type} = $itemtype->sip_media_type() if $itemtype;
# check if its on issue and if so get the borrower
@ -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
next unless ($_->{itemnumber} and $_->{itemnumber} == $self->{itemnumber});
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;
@ -172,12 +187,13 @@ sub hold_patron_id {
if ($id) {
$self->{hold}->{borrowernumber} = $id;
}
if ($self->{hold} ) {
if ( $self->{hold} ) {
return $self->{hold}->{borrowernumber};
}
return;
}
sub hold_patron_name {
my ( $self, $template ) = @_;
my $borrowernumber = $self->hold_patron_id() or return q{};
@ -187,16 +203,16 @@ sub hold_patron_name {
return process_tt( $template, { patron => $patron } );
}
my $holder = Koha::Patrons->find( $borrowernumber );
my $holder = Koha::Patrons->find($borrowernumber);
unless ($holder) {
siplog("LOG_ERR", "While checking hold, failed to retrieve the patron with borrowernumber '$borrowernumber'");
siplog( "LOG_ERR", "While checking hold, failed to retrieve the patron with borrowernumber '$borrowernumber'" );
return q{};
}
my $email = $holder->email || '';
my $phone = $holder->phone || '';
my $extra = ($email and $phone) ? " ($email, $phone)" : # both populated, employ comma
($email or $phone) ? " ($email$phone)" : # only 1 populated, we don't care which: no comma
"" ; # neither populated, empty string
my $extra = ( $email and $phone ) ? " ($email, $phone)" : # both populated, employ comma
( $email or $phone ) ? " ($email$phone)" : # only 1 populated, we don't care which: no comma
""; # neither populated, empty string
my $name = $holder->firstname ? $holder->firstname . ' ' : '';
$name .= $holder->surname . $extra;
return $name;
@ -204,9 +220,9 @@ sub hold_patron_name {
sub hold_patron_bcode {
my $self = shift;
my $borrowernumber = (@_ ? shift: $self->hold_patron_id()) or return q{};
my $holder = Koha::Patrons->find( $borrowernumber );
if ($holder and $holder->cardnumber ) {
my $borrowernumber = ( @_ ? shift : $self->hold_patron_id() ) or return q{};
my $holder = Koha::Patrons->find($borrowernumber);
if ( $holder and $holder->cardnumber ) {
return $holder->cardnumber;
}
return q();
@ -218,7 +234,7 @@ sub destination_loc {
if ($set_loc) {
$self->{dest_loc} = $set_loc;
}
if ($self->{dest_loc} ) {
if ( $self->{dest_loc} ) {
return $self->{dest_loc};
}
return q{};
@ -235,7 +251,7 @@ sub AUTOLOAD {
$name =~ s/.*://;
unless (exists $fields{$name}) {
unless ( exists $fields{$name} ) {
croak "Cannot access '$name' field of class '$class'";
}
@ -248,7 +264,7 @@ sub AUTOLOAD {
}
sub status_update { # FIXME: this looks unimplemented
my ($self, $props) = @_;
my ( $self, $props ) = @_;
my $status = C4::SIP::ILS::Transaction->new();
$self->{sip_item_properties} = $props;
$status->{ok} = 1;
@ -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,38 +322,43 @@ 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 [];
( defined $self->{hold_queue} ) or return [];
return $self->{hold_queue};
}
sub pending_queue {
my $self = shift;
(defined $self->{pending_queue}) or return [];
( defined $self->{pending_queue} ) or return [];
return $self->{pending_queue};
}
sub hold_attached {
my $self = shift;
(defined $self->{hold_attached}) or return [];
( defined $self->{hold_attached} ) or return [];
return $self->{hold_attached};
}
sub hold_queue_position {
my ($self, $patron_id) = @_;
($self->{hold_queue}) or return 0;
my ( $self, $patron_id ) = @_;
( $self->{hold_queue} ) or return 0;
my $i = 0;
foreach (@{$self->{hold_queue}}) {
foreach ( @{ $self->{hold_queue} } ) {
$i++;
$_->{patron_id} or next;
if ($self->barcode_is_borrowernumber($patron_id, $_->{borrowernumber})) {
if ( $self->barcode_is_borrowernumber( $patron_id, $_->{borrowernumber} ) ) {
return $i; # maybe should return $_->{priority}
}
}
@ -347,15 +369,17 @@ 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;
my $hold = Koha::Holds->find({ itemnumber => $self->{itemnumber}, found => 'W' });
if ( $hold ) {
my $hold = Koha::Holds->find( { itemnumber => $self->{itemnumber}, found => 'W' } );
if ($hold) {
return $hold->expirationdate || 0;
}
@ -378,14 +402,15 @@ sub hold_pickup_date {
# they should not be able to place a hold on an item they already have.
sub available {
my ($self, $for_patron) = @_;
my $count = (defined $self->{pending_queue}) ? scalar @{$self->{pending_queue}} : 0;
my $count2 = (defined $self->{hold_attached} ) ? scalar @{$self->{hold_attached} } : 0;
if (defined($self->{borrowernumber})) {
($self->{borrowernumber} eq $for_patron) or return 0;
return ($count ? 0 : 1);
my ( $self, $for_patron ) = @_;
my $count = ( defined $self->{pending_queue} ) ? scalar @{ $self->{pending_queue} } : 0;
my $count2 = ( defined $self->{hold_attached} ) ? scalar @{ $self->{hold_attached} } : 0;
if ( defined( $self->{borrowernumber} ) ) {
( $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;
@ -403,7 +429,7 @@ sub barcode_is_borrowernumber { # because hold_queue only has borrowernumber.
return unless defined $barcode; # might be 0 or 000 or 000000
my $converted = _barcode_to_borrowernumber($barcode);
return unless $converted;
return ($number == $converted);
return ( $number == $converted );
}
=head2 build_additional_item_fields_string
@ -424,7 +450,7 @@ sub build_additional_item_fields_string {
? @{ $server->{account}->{item_field} }
: ( $server->{account}->{item_field} );
foreach my $f ( @fields_to_send ) {
foreach my $f (@fields_to_send) {
my $code = $f->{code};
my $value = $self->{object}->$code;
$string .= add_field( $f->{field}, $value );
@ -437,11 +463,11 @@ sub build_additional_item_fields_string {
? @{ $server->{account}->{custom_item_field} }
: $server->{account}->{custom_item_field};
foreach my $custom_field ( @custom_fields ) {
foreach my $custom_field (@custom_fields) {
my $field = $custom_field->{field};
return q{} unless defined $field;
my $template = $custom_field->{template};
my $formatted = $self->format( $template );
my $formatted = $self->format($template);
my $substring = maybe_add( $field, $formatted, $server );
$string .= $substring;
}
@ -461,7 +487,6 @@ sub build_custom_field_string {
my $string = q{};
return $string;
}

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

@ -39,7 +39,7 @@ our $kp; # koha patron
=cut
sub new {
my ($class, $patron_id) = @_;
my ( $class, $patron_id ) = @_;
my $type = ref($class) || $class;
my $self;
@ -58,12 +58,12 @@ sub new {
}
unless ($patron) {
siplog("LOG_DEBUG", "new ILS::Patron(%s): no such patron", $patron_id);
siplog( "LOG_DEBUG", "new ILS::Patron(%s): no such patron", $patron_id );
return;
}
$kp = $patron->unblessed;
my $pw = $kp->{password};
my $flags = C4::Members::patronflags( $kp );
my $flags = C4::Members::patronflags($kp);
my $debarred = $patron->is_debarred;
siplog( "LOG_DEBUG", "Debarred = %s : ", ( $debarred || 'undef' ) ); # Do we need more debug info here?
my $expired = 0;
@ -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 = (
@ -145,10 +146,10 @@ sub new {
address => $adr,
home_phone => $kp->{phone},
email_addr => $kp->{email},
charge_ok => ( !$debarred && !$expired && !$fine_blocked && !$circ_blocked),
renew_ok => ( !$debarred && !$expired && !$fine_blocked),
recall_ok => ( !$debarred && !$expired && !$fine_blocked),
hold_ok => ( !$debarred && !$expired && !$fine_blocked),
charge_ok => ( !$debarred && !$expired && !$fine_blocked && !$circ_blocked ),
renew_ok => ( !$debarred && !$expired && !$fine_blocked ),
recall_ok => ( !$debarred && !$expired && !$fine_blocked ),
hold_ok => ( !$debarred && !$expired && !$fine_blocked ),
card_lost => ( $kp->{lost} || $kp->{gonenoaddress} || $flags->{LOST} ),
claims_returned => 0,
fines => $personal_fines_amount,
@ -178,16 +179,16 @@ sub new {
$ilspatron{screen_msg} .= " -- " . $patron->debarredcomment;
}
if ( $circ_blocked ) {
if ($circ_blocked) {
$ilspatron{screen_msg} .= " -- " . "Patron has overdues";
}
for (qw(EXPIRED CHARGES CREDITS GNA LOST NOTES)) {
($flags->{$_}) or next;
if ($_ ne 'NOTES' and $flags->{$_}->{message}) {
( $flags->{$_} ) or next;
if ( $_ ne 'NOTES' and $flags->{$_}->{message} ) {
$ilspatron{screen_msg} .= " -- " . $flags->{$_}->{message}; # show all but internal NOTES
}
if ($flags->{$_}->{noissues}) {
if ( $flags->{$_}->{noissues} ) {
foreach my $toggle (qw(charge_ok renew_ok recall_ok hold_ok inet)) {
$ilspatron{$toggle} = 0; # if we get noissues, disable everything
}
@ -213,7 +214,7 @@ sub new {
}
# FIXME: populate recall_items
$ilspatron{unavail_holds} = _get_outstanding_holds($kp->{borrowernumber});
$ilspatron{unavail_holds} = _get_outstanding_holds( $kp->{borrowernumber} );
my $pending_checkouts = $patron->pending_checkouts;
my @barcodes;
@ -223,12 +224,11 @@ sub new {
$ilspatron{items} = \@barcodes;
$self = \%ilspatron;
siplog("LOG_DEBUG", "new ILS::Patron(%s): found patron '%s'", $patron_id,$self->{id});
siplog( "LOG_DEBUG", "new ILS::Patron(%s): found patron '%s'", $patron_id, $self->{id} );
bless $self, $type;
return $self;
}
# 0 means read-only
# 1 means read/write
@ -260,8 +260,9 @@ 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]
# excessive_fines => 0, # for patron_status[10]
# excessive_fees => 0, # for patron_status[11]
recall_overdue => 0, # for patron_status[12]
too_many_billed => 0, # for patron_status[13]
inet => 0, # EnvisionWare extension
@ -270,6 +271,7 @@ my %fields = (
our $AUTOLOAD;
sub DESTROY {
# be cool. needed for AUTOLOAD(?)
}
@ -280,7 +282,7 @@ sub AUTOLOAD {
$name =~ s/.*://;
unless (exists $fields{$name}) {
unless ( exists $fields{$name} ) {
croak "Cannot access '$name' field of class '$class'";
}
@ -335,9 +337,12 @@ This method checks if number of checkouts of lost items exceeds a threshold (def
sub too_many_lost {
my ( $self, $server ) = @_;
my $too_many_lost = 0;
if( $server && $server->{account} && ( my $lost_block_checkout = $server->{account}->{lost_block_checkout} )) {
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;
@ -371,15 +376,15 @@ sub expired {
# return true if I was holding the item, false otherwise.
#
sub drop_hold {
my ($self, $item_id) = @_;
my ( $self, $item_id ) = @_;
return if !$item_id;
my $result = 0;
foreach (qw(hold_items unavail_holds)) {
$self->{$_} or next;
for (my $i = 0; $i < scalar @{$self->{$_}}; $i++) {
for ( my $i = 0 ; $i < scalar @{ $self->{$_} } ; $i++ ) {
my $held_item = $self->{$_}[$i]->{barcode} or next;
if ($held_item eq $item_id) {
splice @{$self->{$_}}, $i, 1;
if ( $held_item eq $item_id ) {
splice @{ $self->{$_} }, $i, 1;
$result++;
}
}
@ -393,25 +398,23 @@ sub drop_hold {
sub x_items {
my $self = shift;
my $array_var = shift or return;
my ($start, $end) = @_;
my ( $start, $end ) = @_;
my $item_list = [];
if ($self->{$array_var}) {
if ( $self->{$array_var} ) {
if ($start && $start > 1) {
if ( $start && $start > 1 ) {
--$start;
}
else {
} else {
$start = 0;
}
if ( $end && $end < @{$self->{$array_var}} ) {
if ( $end && $end < @{ $self->{$array_var} } ) {
--$end;
} else {
$end = @{ $self->{$array_var} };
--$end;
}
else {
$end = @{$self->{$array_var}};
--$end;
}
@{$item_list} = @{$self->{$array_var}}[ $start .. $end ];
@{$item_list} = @{ $self->{$array_var} }[ $start .. $end ];
}
return $item_list;
@ -422,9 +425,9 @@ sub x_items {
#
sub hold_items {
my $self = shift;
my $item_arr = $self->x_items('hold_items', @_);
foreach my $item (@{$item_arr}) {
my $item_obj = Koha::Items->find($item->{itemnumber});
my $item_arr = $self->x_items( 'hold_items', @_ );
foreach my $item ( @{$item_arr} ) {
my $item_obj = Koha::Items->find( $item->{itemnumber} );
$item->{barcode} = $item_obj ? $item_obj->barcode : undef;
}
return $item_arr;
@ -432,12 +435,14 @@ sub hold_items {
sub overdue_items {
my $self = shift;
return $self->x_items('overdue_items', @_);
return $self->x_items( 'overdue_items', @_ );
}
sub charged_items {
my $self = shift;
return $self->x_items('items', @_);
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++ ) {
@ -480,32 +482,37 @@ sub fine_items {
sub recall_items {
my $self = shift;
return $self->x_items('recall_items', @_);
return $self->x_items( 'recall_items', @_ );
}
sub unavail_holds {
my $self = shift;
return $self->x_items('unavail_holds', @_);
return $self->x_items( 'unavail_holds', @_ );
}
sub block {
my ($self, $card_retained, $blocked_card_msg) = @_;
foreach my $field ('charge_ok', 'renew_ok', 'recall_ok', 'hold_ok', 'inet') {
my ( $self, $card_retained, $blocked_card_msg ) = @_;
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;
}
sub enable {
my $self = shift;
foreach my $field ('charge_ok', 'renew_ok', 'recall_ok', 'hold_ok', 'inet') {
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;
}
@ -516,7 +523,7 @@ sub inet_privileges {
sub excessive_fees {
my $self = shift;
return ($self->fee_amount and $self->fee_amount > $self->fee_limit);
return ( $self->fee_amount and $self->fee_amount > $self->fee_limit );
}
sub excessive_fines {
@ -526,13 +533,12 @@ 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 {
my $self = shift;
unless ($self->{library_name}) {
unless ( $self->{library_name} ) {
my $library = Koha::Libraries->find( $self->{branchcode} );
$self->{library_name} = $library ? $library->branchname : '';
}
@ -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};
}
}
@ -573,15 +577,15 @@ sub _get_address {
sub _get_outstanding_holds {
my $borrowernumber = shift;
my $patron = Koha::Patrons->find( $borrowernumber );
my $patron = Koha::Patrons->find($borrowernumber);
my $holds = $patron->holds->search( { -or => [ { found => undef }, { found => { '!=' => 'W' } } ] } );
my @holds;
while ( my $hold = $holds->next ) {
my $item;
if ($hold->itemnumber) {
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;
@ -613,7 +617,7 @@ sub build_patron_attributes_string {
? @{ $server->{account}->{patron_attribute} }
: ( $server->{account}->{patron_attribute} );
foreach my $a ( @attributes_to_send ) {
foreach my $a (@attributes_to_send) {
my @attributes = Koha::Patron::Attributes->search(
{
borrowernumber => $self->{borrowernumber},
@ -621,7 +625,7 @@ sub build_patron_attributes_string {
}
)->as_list;
foreach my $attribute ( @attributes ) {
foreach my $attribute (@attributes) {
my $value = $attribute->attribute();
$string .= add_field( $a->{field}, $value );
}
@ -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
@ -648,8 +651,9 @@ sub build_custom_field_string {
ref $server->{account}->{custom_patron_field} eq "ARRAY"
? @{ $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};
foreach my $custom_field (@custom_fields) {
$string .= maybe_add( $custom_field->{field}, $self->format( $custom_field->{template} ) )
if defined $custom_field->{field};
}
}
return $string;

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

@ -17,7 +17,7 @@ my %fields = (
item => undef,
desensitize => 0,
alert => '',
transaction_id=> undef,
transaction_id => undef,
sip_fee_type => '01', # Other/Unknown
fee_amount => undef,
sip_currency => 'USD', # FIXME: why hardcoded?
@ -38,24 +38,23 @@ sub new {
}
sub duedatefromissue {
my ($self, $iss, $itemnum) = @_;
my ( $self, $iss, $itemnum ) = @_;
my $due_dt;
if (defined $iss ) {
if ( defined $iss ) {
$due_dt = dt_from_string( $iss->date_due() );
} # renew from AddIssue ??
else {
# need to reread the issue to get due date
$iss = Koha::Checkouts->find( { itemnumber => $itemnum } );
if ($iss && $iss->date_due ) {
if ( $iss && $iss->date_due ) {
$due_dt = dt_from_string( $iss->date_due, 'sql' );
}
}
return $due_dt;
}
sub DESTROY {
# be cool
}
@ -66,7 +65,7 @@ sub AUTOLOAD {
$name =~ s/.*://;
unless (exists $self->{_permitted}->{$name}) {
unless ( exists $self->{_permitted}->{$name} ) {
croak "Can't access '$name' field of class '$class'";
}

91
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,
@ -36,11 +37,11 @@ sub new {
my $class = shift;
my $self = $class->SUPER::new(); # start with an ILS::Transaction object
foreach (keys %fields) {
foreach ( keys %fields ) {
$self->{_permitted}->{$_} = $fields{$_}; # overlaying _permitted
}
@{$self}{keys %fields} = values %fields; # copying defaults into object
@{$self}{ keys %fields } = values %fields; # copying defaults into object
return bless $self, $class;
}
@ -55,22 +56,18 @@ sub do_checkin {
my $holds_block_checkin = $account->{holds_block_checkin};
my $holds_get_captured = $account->{holds_get_captured} // 1;
if (!$branch) {
if ( !$branch ) {
$branch = 'SIP2';
}
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 )
. ':'
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 ) . ':'
. substr( $return_date, 16, 2 );
$return_date = dt_from_string($return_date);
}
@ -91,17 +88,16 @@ sub do_checkin {
my $reserved;
my $lookahead = C4::Context->preference('ConfirmFutureHolds'); #number of days to look for future holds
my ($resfound) = $item->withdrawn ? q{} : CheckReserves( $item, $lookahead );
if ( $resfound eq "Reserved") {
if ( $resfound eq "Reserved" ) {
$reserved = 1;
}
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 ) {
if ($checked_in_ok) {
delete $messages->{ItemLocationUpdated};
delete $messages->{NotIssued};
delete $messages->{LocalUse};
@ -111,43 +107,43 @@ sub do_checkin {
# biblionumber, biblioitemnumber, itemnumber
# borrowernumber, reservedate, branchcode
# cancellationdate, found, reservenotes, priority, timestamp
if ($messages->{additional_materials}) {
if ( $messages->{additional_materials} ) {
$self->alert_type('99');
}
if( $messages->{DataCorrupted} ) {
if ( $messages->{DataCorrupted} ) {
$self->alert_type('98');
}
if ($messages->{BadBarcode}) {
if ( $messages->{BadBarcode} ) {
$self->alert_type('99');
}
if ($messages->{withdrawn}) {
if ( $messages->{withdrawn} ) {
$self->alert_type('99');
}
if ($messages->{WasLost}) {
if ( $messages->{WasLost} ) {
$self->alert_type('99') if C4::Context->preference("BlockReturnOfLostItems");
}
if ($messages->{Wrongbranch}) {
$self->{item}->destination_loc($messages->{Wrongbranch}->{Rightbranch});
if ( $messages->{Wrongbranch} ) {
$self->{item}->destination_loc( $messages->{Wrongbranch}->{Rightbranch} );
$self->alert_type('04'); # send to other branch
}
if ($messages->{WrongTransfer}) {
$self->{item}->destination_loc($messages->{WrongTransfer});
if ( $messages->{WrongTransfer} ) {
$self->{item}->destination_loc( $messages->{WrongTransfer} );
$self->alert_type('04'); # send to other branch
}
if ($messages->{NeedsTransfer}) {
$self->{item}->destination_loc($messages->{NeedsTransfer});
if ( $messages->{NeedsTransfer} ) {
$self->{item}->destination_loc( $messages->{NeedsTransfer} );
$self->alert_type('04'); # send to other branch
}
if ($messages->{WasTransfered}) { # set into transit so tell unit
$self->{item}->destination_loc($item->homebranch);
if ( $messages->{WasTransfered} ) { # set into transit so tell unit
$self->{item}->destination_loc( $item->homebranch );
$self->alert_type('04'); # send to other branch
}
if ($messages->{ResFound} || $checkin_blocked_by_holds ) {
if ( $messages->{ResFound} || $checkin_blocked_by_holds ) {
if ($checkin_blocked_by_holds) {
$self->alert_type('99');
$return = 0;
} elsif ($branch eq $messages->{ResFound}->{branchcode}) {
$self->hold($messages->{ResFound});
} elsif ( $branch eq $messages->{ResFound}->{branchcode} ) {
$self->hold( $messages->{ResFound} );
$self->alert_type('01');
ModReserveAffect(
$messages->{ResFound}->{itemnumber},
@ -156,25 +152,30 @@ sub do_checkin {
) if $holds_get_captured;
} else {
$self->hold($messages->{ResFound});
$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 );
}
@ -189,7 +190,7 @@ sub do_checkin {
sub resensitize {
my $self = shift;
unless ($self->{item}) {
unless ( $self->{item} ) {
warn "resensitize(): no item found in object to resensitize";
return;
}
@ -198,7 +199,7 @@ sub resensitize {
sub patron_id {
my $self = shift;
unless ($self->{patron}) {
unless ( $self->{patron} ) {
warn "patron_id(): no patron found in object";
return;
}
@ -266,7 +267,7 @@ sub _get_sort_bin {
# Iterate over the mapping. The first hit wins.
my $rule = 0;
RULE: foreach my $line (@lines) {
RULE: foreach my $line (@lines) {
# Skip empty lines and comments
next if ( $line =~ /^\s*($|#)/ );

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

@ -27,15 +27,15 @@ my %fields = (
security_inhibit => 0,
due => undef,
renew_ok => 0,
);
);
sub new {
my $class = shift;;
my $class = shift;
my $self = $class->SUPER::new();
foreach my $element (keys %fields) {
foreach my $element ( keys %fields ) {
$self->{_permitted}->{$element} = $fields{$element};
}
@{$self}{keys %fields} = values %fields;
@{$self}{ keys %fields } = values %fields;
return bless $self, $class;
}
@ -52,19 +52,19 @@ sub do_checkout {
my $allow_additional_materials_checkout = $account->{allow_additional_materials_checkout};
my ( $issuingimpossible, $needsconfirmation, $messages ) = _can_we_issue( $patron, $barcode, 0 );
if ( $no_block_due_date ) {
my $year = substr($no_block_due_date,0,4);
my $month = substr($no_block_due_date,4,2);
my $day = substr($no_block_due_date,6,2);
my $hour = substr($no_block_due_date,12,2);
my $minute = substr($no_block_due_date,14,2);
my $second = substr($no_block_due_date,16,2);
if ($no_block_due_date) {
my $year = substr( $no_block_due_date, 0, 4 );
my $month = substr( $no_block_due_date, 4, 2 );
my $day = substr( $no_block_due_date, 6, 2 );
my $hour = substr( $no_block_due_date, 12, 2 );
my $minute = substr( $no_block_due_date, 14, 2 );
my $second = substr( $no_block_due_date, 16, 2 );
my $iso = "$year-$month-$day $hour:$minute:$second";
$no_block_due_date = dt_from_string( $iso, "iso" );
}
my $noerror=1; # If set to zero we block the issue
my $noerror = 1; # If set to zero we block the issue
if ( keys %{$issuingimpossible} ) {
foreach ( keys %{$issuingimpossible} ) {
@ -136,11 +136,11 @@ sub do_checkout {
}
}
my $itemnumber = $self->{item}->{itemnumber};
my ($fee, undef) = GetIssuingCharges($itemnumber, $patron->borrowernumber);
my ( $fee, undef ) = GetIssuingCharges( $itemnumber, $patron->borrowernumber );
if ( $fee > 0 ) {
$self->{sip_fee_type} = '06';
$self->{fee_amount} = sprintf '%.2f', $fee;
if ($self->{fee_ack} eq 'N' ) {
if ( $self->{fee_ack} eq 'N' ) {
$noerror = 0;
}
}
@ -150,14 +150,17 @@ sub do_checkout {
return $self;
}
if ( $no_block_due_date ) {
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} ) {

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

@ -70,13 +70,10 @@ sub pay {
if ($fee_id) {
my $fee = Koha::Account::Lines->find($fee_id);
if ( $fee ) {
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;
}
};

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