Koha/C4/SQLHelper.pm
Jared Camins-Esakov 480841965e Bug 10403: add ability to change fund on receipt
Right now there is no way to change the budget or fund when receiving an
item, which is annoying, particularly at the end of the fiscal year when
every item not already received has to be switched to the following
year's budget. This patch adds the ability to change the budget and fund
when receiving.

To test:
1) Apply patch.
2) Create an order for a vendor, choosing a fund to use for that order.
3) Receive the order, leaving the fund unchanged. Make sure the fund
   did not change.
4) Create another order for a vendor, choosing a fund to use for that
   order.
5) Receive the order, this time changing the fund. Make sure the fund
   is changed.
6) Run the unit test:
    > prove t/db_dependent/Acquisition.t
7) Sign off.

(Notes: this patch depends on the Acquisitions.t unit test improvements
in bug 10274; the seemingly-unrelated change in SQLHelper quiets an
irritating warning caused by the NewOrder call in ModReceiveOrder)

Signed-off-by: Mathieu Saby <mathieu.saby@univ-rennes2.fr>

Signed-off-by: Jonathan Druart <jonathan.druart@biblibre.com>
Signed-off-by: Galen Charlton <gmc@esilibrary.com>
2013-10-22 12:57:25 +00:00

500 lines
13 KiB
Perl

package C4::SQLHelper;
# Copyright 2009 Biblibre SARL
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
use warnings;
use List::MoreUtils qw(first_value any);
use C4::Context;
use C4::Dates qw(format_date_in_iso);
use C4::Debug;
require Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
eval {
my $servers = C4::Context->config('memcached_servers');
if ($servers) {
require Memoize::Memcached;
import Memoize::Memcached qw(memoize_memcached);
my $memcached = {
servers => [$servers],
key_prefix => C4::Context->config('memcached_namespace') || 'koha',
expire_time => 600
}; # cache for 10 mins
memoize_memcached( '_get_columns', memcached => $memcached );
memoize_memcached( 'GetPrimaryKeys', memcached => $memcached );
}
};
BEGIN {
# set the version for version checking
$VERSION = 3.07.00.049;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK=qw(
InsertInTable
DeleteInTable
SearchInTable
UpdateInTable
GetPrimaryKeys
clear_columns_cache
);
%EXPORT_TAGS = ( all =>[qw( InsertInTable DeleteInTable SearchInTable UpdateInTable GetPrimaryKeys)]
);
}
my $tablename;
my $hashref;
=head1 NAME
C4::SQLHelper - Perl Module containing convenience functions for SQL Handling
=head1 SYNOPSIS
use C4::SQLHelper;
=head1 DESCRIPTION
This module contains routines for adding, modifying and Searching Data in MysqlDB
=head1 FUNCTIONS
=head2 SearchInTable
$hashref = &SearchInTable($tablename,$data, $orderby, $limit,
$columns_out, $filtercolumns, $searchtype);
$tablename Name of the table (string)
$data may contain
- string
- data_hashref : will be considered as an AND of all the data searched
- data_array_ref on hashrefs : Will be considered as an OR of Datahasref elements
$orderby is an arrayref of hashref with fieldnames as key and 0 or 1 as values (ASCENDING or DESCENDING order)
$limit is an array ref on 2 values in order to limit results to MIN..MAX
$columns_out is an array ref on field names is used to limit results on those fields (* by default)
$filtercolums is an array ref on field names : is used to limit expansion of research for strings
$searchtype is string Can be "start_with" or "exact"
This query builder is very limited, it should be replaced with DBIx::Class
or similar very soon
Meanwhile adding support for special key '' in case of a data_hashref to
support filters of type
( f1 = a OR f2 = a ) AND fx = b AND fy = c
Call for the query above is:
SearchInTable($tablename, {'' => a, fx => b, fy => c}, $orderby, $limit,
$columns_out, [f1, f2], 'exact');
NOTE: Current implementation may remove parts of the iinput hashrefs. If that is a problem
a copy needs to be created in _filter_fields() below
=cut
sub SearchInTable{
my ($tablename,$filters,$orderby, $limit, $columns_out, $filter_columns,$searchtype) = @_;
$searchtype||="exact";
my $dbh = C4::Context->dbh;
$columns_out||=["*"];
my $sql = do { local $"=', ';
qq{ SELECT @$columns_out from $tablename}
};
my $row;
my $sth;
my ($keys,$values)=_filter_fields($tablename,$filters,$searchtype,$filter_columns);
if ($keys){
my @criteria=grep{defined($_) && $_ !~/^\W$/ }@$keys;
if (@criteria) {
$sql.= do { local $"=') OR (';
qq{ WHERE (@criteria) }
};
}
}
if ($orderby){
#Order by desc by default
my @orders;
foreach my $order ( ref($orderby) ? @$orderby : $orderby ){
if (ref $order) {
push @orders,map{ "$_".($order->{$_}? " DESC " : "") } keys %$order;
} else {
push @orders,$order;
}
}
$sql.= do { local $"=', ';
qq{ ORDER BY @orders}
};
}
if ($limit){
$sql.=qq{ LIMIT }.join(",",@$limit);
}
$debug && $values && warn $sql," ",join(",",@$values);
$sth = $dbh->prepare_cached($sql);
eval{$sth->execute(@$values)};
warn $@ if ($@ && $debug);
my $results = $sth->fetchall_arrayref( {} );
return $results;
}
=head2 InsertInTable
$data_id_in_table = &InsertInTable($tablename,$data_hashref,$withprimarykeys);
Insert Data in table and returns the id of the row inserted
=cut
sub InsertInTable{
my ($tablename,$data,$withprimarykeys) = @_;
my $dbh = C4::Context->dbh;
my ($keys,$values)=_filter_hash($tablename,$data,($withprimarykeys?"exact":0));
my $query = qq{ INSERT INTO $tablename SET }.join(", ",@$keys);
$debug && warn $query, join(",",@$values);
my $sth = $dbh->prepare_cached($query);
eval{$sth->execute(@$values)};
warn $@ if ($@ && $debug);
return $dbh->last_insert_id(undef, undef, $tablename, undef);
}
=head2 UpdateInTable
$status = &UpdateInTable($tablename,$data_hashref);
Update Data in table and returns the status of the operation
=cut
sub UpdateInTable{
my ($tablename,$data) = @_;
my @field_ids=GetPrimaryKeys($tablename);
my @ids=@$data{@field_ids};
my $dbh = C4::Context->dbh;
my ($keys,$values)=_filter_hash($tablename,$data,0);
return unless ($keys);
my $query =
qq{ UPDATE $tablename
SET }.join(",",@$keys).qq{
WHERE }.join (" AND ",map{ "$_=?" }@field_ids);
$debug && warn $query, join(",",@$values,@ids);
my $sth = $dbh->prepare_cached($query);
my $result;
eval{$result=$sth->execute(@$values,@ids)};
warn $@ if ($@ && $debug);
return $result;
}
=head2 DeleteInTable
$status = &DeleteInTable($tablename,$data_hashref);
Delete Data in table and returns the status of the operation
=cut
sub DeleteInTable{
my ($tablename,$data) = @_;
my $dbh = C4::Context->dbh;
my ($keys,$values)=_filter_fields($tablename,$data,1);
if ($keys){
my $query = do { local $"=') AND (';
qq{ DELETE FROM $tablename WHERE (@$keys)};
};
$debug && warn $query, join(",",@$values);
my $sth = $dbh->prepare_cached($query);
my $result;
eval{$result=$sth->execute(@$values)};
warn $@ if ($@ && $debug);
return $result;
}
}
=head2 GetPrimaryKeys
@primarykeys = &GetPrimaryKeys($tablename)
Get the Primary Key field names of the table
=cut
sub GetPrimaryKeys {
my $tablename=shift;
my $hash_columns=_get_columns($tablename);
return grep { $hash_columns->{$_}->{'Key'} =~/PRI/i} keys %$hash_columns;
}
=head2 clear_columns_cache
C4::SQLHelper->clear_columns_cache();
cleans the internal cache of sysprefs. Please call this method if
you update a tables structure. Otherwise, your new changes
will not be seen by this process.
=cut
sub clear_columns_cache {
%$hashref = ();
}
=head2 _get_columns
_get_columns($tablename)
Given a tablename
Returns a hashref of all the fieldnames of the table
With
Key
Type
Default
=cut
sub _get_columns {
my ($tablename) = @_;
unless ( exists( $hashref->{$tablename} ) ) {
my $dbh = C4::Context->dbh;
my $sth = $dbh->prepare_cached(qq{SHOW COLUMNS FROM $tablename });
$sth->execute;
my $columns = $sth->fetchall_hashref(qw(Field));
$hashref->{$tablename} = $columns;
}
return $hashref->{$tablename};
}
=head2 _filter_columns
=over 4
_filter_columns($tablename,$research, $filtercolumns)
=back
Given
- a tablename
- indicator on purpose whether all fields should be returned or only non Primary keys
- array_ref to columns to limit to
Returns an array of all the fieldnames of the table
If it is not for research purpose, filter primary keys
=cut
sub _filter_columns {
my ($tablename,$research, $filtercolumns)=@_;
if ($filtercolumns){
return (@$filtercolumns);
}
else {
my $columns=_get_columns($tablename);
if ($research){
return keys %$columns;
}
else {
return grep {my $column=$_; any {$_ ne $column }GetPrimaryKeys($tablename) } keys %$columns;
}
}
}
=head2 _filter_fields
_filter_fields
Given
- a tablename
- a string or a hashref (containing, fieldnames and datatofilter) or an arrayref to one of those elements
- an indicator of operation whether it is a wide research or a narrow one
- an array ref to columns to restrict string filter to.
Returns a ref of key array to use in SQL functions
and a ref to value array
=cut
sub _filter_fields{
my ($tablename,$filter_input,$searchtype,$filtercolumns)=@_;
my @keys;
my @values;
if (ref($filter_input) eq "HASH"){
my ($keys, $values);
if (my $special = delete $filter_input->{''}) { # XXX destroyes '' key
($keys, $values) = _filter_fields($tablename,$special, $searchtype,$filtercolumns);
}
my ($hkeys, $hvalues) = _filter_hash($tablename,$filter_input, $searchtype);
if ($hkeys){
push @$keys, @$hkeys;
push @$values, @$hvalues;
}
if ($keys){
my $stringkey="(".join (") AND (",@$keys).")";
return [$stringkey],$values;
}
else {
return ();
}
} elsif (ref($filter_input) eq "ARRAY"){
foreach my $element_data (@$filter_input){
my ($localkeys,$localvalues)=_filter_fields($tablename,$element_data,$searchtype,$filtercolumns);
if ($localkeys){
@$localkeys=grep{defined($_) && $_ !~/^\W*$/}@$localkeys;
my $string=do{
local $"=") OR (";
qq{(@$localkeys)}
};
push @keys, $string;
push @values, @$localvalues;
}
}
}
else{
$debug && warn "filterstring : $filter_input";
my ($keys, $values) = _filter_string($tablename,$filter_input, $searchtype,$filtercolumns);
if ($keys){
my $stringkey="(".join (") AND (",@$keys).")";
return [$stringkey],$values;
}
else {
return ();
}
}
return (\@keys,\@values);
}
sub _filter_hash{
my ($tablename,$filter_input, $searchtype)=@_;
my (@values, @keys);
my $columns= _get_columns($tablename);
my @columns_filtered= _filter_columns($tablename,$searchtype);
#Filter Primary Keys of table
my $elements=join "|",@columns_filtered;
foreach my $field (grep {/\b($elements)\b/} keys %$filter_input){
## supposed to be a hash of simple values, hashes of arrays could be implemented
$filter_input->{$field}=format_date_in_iso($filter_input->{$field})
if $columns->{$field}{Type}=~/date/ &&
($filter_input->{$field} && $filter_input->{$field} !~C4::Dates->regexp("iso"));
my ($tmpkeys, $localvalues)=_Process_Operands($filter_input->{$field},"$tablename.$field",$searchtype,$columns);
if (@$tmpkeys){
push @values, @$localvalues;
push @keys, @$tmpkeys;
}
}
if (@keys){
return (\@keys,\@values);
}
else {
return ();
}
}
sub _filter_string{
my ($tablename,$filter_input, $searchtype,$filtercolumns)=@_;
return () unless($filter_input);
my @operands=split /\s+/,$filter_input;
# An act of desperation
$searchtype = 'contain' if @operands > 1 && $searchtype =~ /start_with/o;
my @columns_filtered= _filter_columns($tablename,$searchtype,$filtercolumns);
my $columns= _get_columns($tablename);
my (@values,@keys);
foreach my $operand (@operands){
my @localkeys;
foreach my $field (@columns_filtered){
my ($tmpkeys, $localvalues)=_Process_Operands($operand,"$tablename.$field",$searchtype,$columns);
if ($tmpkeys){
push @values,@$localvalues;
push @localkeys,@$tmpkeys;
}
}
my $sql= join (' OR ', @localkeys);
push @keys, $sql;
}
if (@keys){
return (\@keys,\@values);
}
else {
return ();
}
}
sub _Process_Operands{
my ($operand, $field, $searchtype,$columns)=@_;
my @values;
my @tmpkeys;
my @localkeys;
$operand = [$operand] unless ref $operand eq 'ARRAY';
foreach (@$operand) {
push @tmpkeys, " $field = ? ";
push @values, $_;
}
#By default, exact search
if (!$searchtype ||$searchtype eq "exact"){
return \@tmpkeys,\@values;
}
my $col_field=(index($field,".")>0?substr($field, index($field,".")+1):$field);
if ($field=~/(?<!zip)code|(?<!card)number/ && $searchtype ne "exact"){
push @tmpkeys,(" $field= '' ","$field IS NULL");
}
if ($columns->{$col_field}->{Type}=~/varchar|text/i){
my @localvaluesextended;
if ($searchtype eq "contain"){
foreach (@$operand) {
push @tmpkeys,(" $field LIKE ? ");
push @localvaluesextended,("\%$_\%") ;
}
}
if ($searchtype eq "field_start_with"){
foreach (@$operand) {
push @tmpkeys,("$field LIKE ?");
push @localvaluesextended, ("$_\%") ;
}
}
if ($searchtype eq "start_with"){
foreach (@$operand) {
push @tmpkeys,("$field LIKE ?","$field LIKE ?");
push @localvaluesextended, ("$_\%", " $_\%") ;
}
}
push @values,@localvaluesextended;
}
push @localkeys,qq{ (}.join(" OR ",@tmpkeys).qq{) };
return (\@localkeys,\@values);
}
1;