View | Details | Raw Unified | Return to bug 11385
Collapse All | Expand All

(-)a/C4/SQLHelper.pm (-506 lines)
Lines 1-506 Link Here
1
package C4::SQLHelper;
2
3
# Copyright 2009 Biblibre SARL
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it under the
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License along
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
21
use strict;
22
use warnings;
23
use List::MoreUtils qw(first_value any);
24
use C4::Context;
25
use C4::Dates qw(format_date_in_iso);
26
use C4::Debug;
27
require Exporter;
28
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
29
30
eval {
31
    my $servers = C4::Context->config('memcached_servers');
32
    if ($servers) {
33
        require Memoize::Memcached;
34
        import Memoize::Memcached qw(memoize_memcached);
35
36
        my $memcached = {
37
            servers     => [$servers],
38
            key_prefix  => C4::Context->config('memcached_namespace') || 'koha',
39
            expire_time => 600
40
        };    # cache for 10 mins
41
42
        memoize_memcached( '_get_columns',   memcached => $memcached );
43
        memoize_memcached( 'GetPrimaryKeys', memcached => $memcached );
44
    }
45
};
46
47
BEGIN {
48
	# set the version for version checking
49
    $VERSION = 3.07.00.049;
50
	require Exporter;
51
	@ISA    = qw(Exporter);
52
@EXPORT_OK=qw(
53
	InsertInTable
54
	DeleteInTable
55
	SearchInTable
56
	UpdateInTable
57
	GetPrimaryKeys
58
        clear_columns_cache
59
);
60
	%EXPORT_TAGS = ( all =>[qw( InsertInTable DeleteInTable SearchInTable UpdateInTable GetPrimaryKeys)]
61
				);
62
}
63
64
my $tablename;
65
my $hashref;
66
67
=head1 NAME
68
69
C4::SQLHelper - Perl Module containing convenience functions for SQL Handling
70
71
=head1 SYNOPSIS
72
73
use C4::SQLHelper;
74
75
=head1 DESCRIPTION
76
77
This module contains routines for adding, modifying and Searching Data in MysqlDB 
78
79
=head1 FUNCTIONS
80
81
=head2 SearchInTable
82
83
  $hashref = &SearchInTable($tablename,$data, $orderby, $limit, 
84
                      $columns_out, $filtercolumns, $searchtype);
85
86
87
$tablename Name of the table (string)
88
89
$data may contain 
90
	- string
91
92
	- data_hashref : will be considered as an AND of all the data searched
93
94
	- data_array_ref on hashrefs : Will be considered as an OR of Datahasref elements
95
96
$orderby is an arrayref of hashref with fieldnames as key and 0 or 1 as values (ASCENDING or DESCENDING order)
97
98
$limit is an array ref on 2 values in order to limit results to MIN..MAX
99
100
$columns_out is an array ref on field names is used to limit results on those fields (* by default)
101
102
$filtercolums is an array ref on field names : is used to limit expansion of research for strings
103
104
$searchtype is string Can be "start_with" or "exact" 
105
106
This query builder is very limited, it should be replaced with DBIx::Class
107
or similar  very soon
108
Meanwhile adding support for special key '' in case of a data_hashref to
109
support filters of type
110
111
  ( f1 = a OR f2 = a ) AND fx = b AND fy = c
112
113
Call for the query above is:
114
115
  SearchInTable($tablename, {'' => a, fx => b, fy => c}, $orderby, $limit,
116
                $columns_out, [f1, f2], 'exact');
117
118
NOTE: Current implementation may remove parts of the iinput hashrefs. If that is a problem
119
a copy needs to be created in _filter_fields() below
120
121
=cut
122
123
sub SearchInTable{
124
    my ($tablename,$filters,$orderby, $limit, $columns_out, $filter_columns,$searchtype) = @_; 
125
	$searchtype||="exact";
126
    my $dbh      = C4::Context->dbh; 
127
	$columns_out||=["*"];
128
    my $sql      = do { local $"=', '; 
129
                qq{ SELECT @$columns_out from $tablename} 
130
               };
131
    my $row; 
132
    my $sth; 
133
    my ($keys,$values)=_filter_fields($tablename,$filters,$searchtype,$filter_columns); 
134
	if ($keys){
135
		my @criteria=grep{defined($_) && $_ !~/^\W$/ }@$keys;
136
		if (@criteria) { 
137
			$sql.= do { local $"=') OR ('; 
138
					qq{ WHERE (@criteria) } 
139
				   }; 
140
		} 
141
	}
142
    if ($orderby){ 
143
		#Order by desc by default
144
		my @orders;
145
		foreach my $order ( ref($orderby) ? @$orderby : $orderby ){
146
            if (ref $order) {
147
			    push @orders,map{ "$_".($order->{$_}? " DESC " : "") } keys %$order; 
148
            } else {
149
			    push @orders,$order; 
150
            }
151
		}
152
		$sql.= do { local $"=', '; 
153
				qq{ ORDER BY @orders} 
154
        }; 
155
    } 
156
	if ($limit){
157
		$sql.=qq{ LIMIT }.join(",",@$limit);
158
	}
159
     
160
    $debug && $values && warn $sql," ",join(",",@$values); 
161
    $sth = $dbh->prepare_cached($sql); 
162
    eval{$sth->execute(@$values)}; 
163
	warn $@ if ($@ && $debug);
164
    my $results = $sth->fetchall_arrayref( {} ); 
165
    return $results;
166
}
167
168
=head2 InsertInTable
169
170
  $data_id_in_table = &InsertInTable($tablename,$data_hashref,$withprimarykeys);
171
172
Insert Data in table and returns the id of the row inserted
173
174
=cut
175
176
sub InsertInTable{
177
    my ($tablename,$data,$withprimarykeys) = @_;
178
    my $dbh      = C4::Context->dbh;
179
    my ($keys,$values)=_filter_hash($tablename,$data,($withprimarykeys?"exact":0));
180
    my $query = qq{ INSERT INTO $tablename SET  }.join(", ",@$keys);
181
182
	$debug && warn $query, join(",",@$values);
183
    my $sth = $dbh->prepare_cached($query);
184
    eval{$sth->execute(@$values)}; 
185
	warn $@ if ($@ && $debug);
186
187
	return $dbh->last_insert_id(undef, undef, $tablename, undef);
188
}
189
190
=head2 UpdateInTable
191
192
  $status = &UpdateInTable($tablename,$data_hashref);
193
194
Update Data in table and returns the status of the operation
195
196
=cut
197
198
sub UpdateInTable{
199
    my ($tablename,$data) = @_;
200
	my @field_ids=GetPrimaryKeys($tablename);
201
    my @ids=@$data{@field_ids};
202
    my $dbh      = C4::Context->dbh;
203
    my ($keys,$values)=_filter_hash($tablename,$data,0);
204
    return unless ($keys);
205
    my $query = 
206
    qq{     UPDATE $tablename
207
            SET  }.join(",",@$keys).qq{
208
            WHERE }.join (" AND ",map{ "$_=?" }@field_ids);
209
	$debug && warn $query, join(",",@$values,@ids);
210
211
    my $sth = $dbh->prepare_cached($query);
212
	my $result;
213
    eval{$result=$sth->execute(@$values,@ids)}; 
214
	warn $@ if ($@ && $debug);
215
    return $result;
216
}
217
218
=head2 DeleteInTable
219
220
  $status = &DeleteInTable($tablename,$data_hashref);
221
222
Delete Data in table and returns the status of the operation
223
224
=cut
225
226
sub DeleteInTable{
227
    my ($tablename,$data) = @_;
228
    my $dbh      = C4::Context->dbh;
229
    my ($keys,$values)=_filter_fields($tablename,$data,1);
230
	if ($keys){
231
		my $query = do { local $"=') AND (';
232
		qq{ DELETE FROM $tablename WHERE (@$keys)};
233
		};
234
		$debug && warn $query, join(",",@$values);
235
		my $sth = $dbh->prepare_cached($query);
236
   		my $result;
237
    	eval{$result=$sth->execute(@$values)}; 
238
		warn $@ if ($@ && $debug);
239
    	return $result;
240
	}
241
}
242
243
=head2 GetPrimaryKeys
244
245
  @primarykeys = &GetPrimaryKeys($tablename)
246
247
Get the Primary Key field names of the table
248
249
=cut
250
251
sub GetPrimaryKeys {
252
	my $tablename=shift;
253
	my $hash_columns=_get_columns($tablename);
254
	return  grep { $hash_columns->{$_}->{'Key'} =~/PRI/i}  keys %$hash_columns;
255
}
256
257
258
=head2 clear_columns_cache
259
260
  C4::SQLHelper->clear_columns_cache();
261
262
cleans the internal cache of sysprefs. Please call this method if
263
you update a tables structure. Otherwise, your new changes
264
will not be seen by this process.
265
266
=cut
267
268
sub clear_columns_cache {
269
    %$hashref = ();
270
}
271
272
273
274
=head2 _get_columns
275
276
    _get_columns($tablename)
277
278
Given a tablename 
279
Returns a hashref of all the fieldnames of the table
280
With 
281
	Key
282
	Type
283
	Default
284
285
=cut
286
287
sub _get_columns {
288
    my ($tablename) = @_;
289
    unless ( exists( $hashref->{$tablename} ) ) {
290
        my $dbh = C4::Context->dbh;
291
        my $sth = $dbh->prepare_cached(qq{SHOW COLUMNS FROM $tablename });
292
        $sth->execute;
293
        my $columns = $sth->fetchall_hashref(qw(Field));
294
        $hashref->{$tablename} = $columns;
295
    }
296
    return $hashref->{$tablename};
297
}
298
299
=head2 _filter_columns
300
301
=over 4
302
303
_filter_columns($tablename,$research, $filtercolumns)
304
305
=back
306
307
Given 
308
	- a tablename 
309
	- indicator on purpose whether all fields should be returned or only non Primary keys
310
	- array_ref to columns to limit to
311
312
Returns an array of all the fieldnames of the table
313
If it is not for research purpose, filter primary keys
314
315
=cut
316
317
sub _filter_columns {
318
	my ($tablename,$research, $filtercolumns)=@_;
319
	if ($filtercolumns){
320
		return (@$filtercolumns);
321
	}
322
	else {
323
		my $columns=_get_columns($tablename);
324
		if ($research){
325
			return keys %$columns;
326
		}
327
		else {
328
			return grep {my $column=$_; any {$_ ne $column }GetPrimaryKeys($tablename) } keys %$columns;
329
		}
330
	}
331
}
332
=head2 _filter_fields
333
334
  _filter_fields
335
336
Given 
337
	- a tablename
338
	- a string or a hashref (containing, fieldnames and datatofilter) or an arrayref to one of those elements
339
	- an indicator of operation whether it is a wide research or a narrow one
340
	- an array ref to columns to restrict string filter to.
341
342
Returns a ref of key array to use in SQL functions
343
and a ref to value array
344
345
=cut
346
347
sub _filter_fields{
348
	my ($tablename,$filter_input,$searchtype,$filtercolumns)=@_;
349
    my @keys; 
350
	my @values;
351
	if (ref($filter_input) eq "HASH"){
352
		my ($keys, $values);
353
        if (my $special = delete $filter_input->{''}) { # XXX destroyes '' key
354
		    ($keys, $values) = _filter_fields($tablename,$special, $searchtype,$filtercolumns);
355
        }
356
		my ($hkeys, $hvalues) = _filter_hash($tablename,$filter_input, $searchtype);
357
		if ($hkeys){
358
            push @$keys, @$hkeys;
359
            push @$values, @$hvalues;
360
        }
361
		if ($keys){
362
		    my $stringkey="(".join (") AND (",@$keys).")";
363
		    return [$stringkey],$values;
364
		}
365
		else {
366
		    return ();
367
		}
368
	} elsif (ref($filter_input) eq "ARRAY"){
369
		foreach my $element_data (@$filter_input){
370
			my ($localkeys,$localvalues)=_filter_fields($tablename,$element_data,$searchtype,$filtercolumns);
371
			if ($localkeys){
372
				@$localkeys=grep{defined($_) && $_ !~/^\W*$/}@$localkeys;
373
				my $string=do{ 
374
								local $"=") OR (";
375
								qq{(@$localkeys)}
376
							};
377
				push @keys, $string;
378
				push @values, @$localvalues;
379
			}
380
		}
381
	} 
382
	else{
383
        $debug && warn "filterstring : $filter_input";
384
		my ($keys, $values) = _filter_string($tablename,$filter_input, $searchtype,$filtercolumns);
385
		if ($keys){
386
		my $stringkey="(".join (") AND (",@$keys).")";
387
		return [$stringkey],$values;
388
		}
389
		else {
390
		return ();
391
		}
392
	}
393
394
	return (\@keys,\@values);
395
}
396
397
sub _filter_hash{
398
	my ($tablename,$filter_input, $searchtype)=@_;
399
	my (@values, @keys);
400
	my $columns= _get_columns($tablename);
401
	my @columns_filtered= _filter_columns($tablename,$searchtype);
402
	
403
	#Filter Primary Keys of table
404
    my $elements=join "|",@columns_filtered;
405
	foreach my $field (grep {/\b($elements)\b/} keys %$filter_input){
406
		## supposed to be a hash of simple values, hashes of arrays could be implemented
407
        if ( $columns->{$field}{Type}=~/date/ ) {
408
            if ( defined $filter_input->{$field} ) {
409
                if ( $filter_input->{$field} eq q{} ) {
410
                    $filter_input->{$field} = undef;
411
                } elsif ( $filter_input->{$field} !~ C4::Dates->regexp("iso") ) {
412
                    $filter_input->{$field} = format_date_in_iso($filter_input->{$field});
413
                }
414
            }
415
        }
416
		my ($tmpkeys, $localvalues)=_Process_Operands($filter_input->{$field},"$tablename.$field",$searchtype,$columns);
417
		if (@$tmpkeys){
418
			push @values, @$localvalues;
419
			push @keys, @$tmpkeys;
420
		}
421
	}
422
	if (@keys){
423
		return (\@keys,\@values);
424
	}
425
	else {
426
		return ();
427
	}
428
}
429
430
sub _filter_string{
431
	my ($tablename,$filter_input, $searchtype,$filtercolumns)=@_;
432
	return () unless($filter_input);
433
	my @operands=split /\s+/,$filter_input;
434
435
    # An act of desperation
436
    $searchtype = 'contain' if @operands > 1 && $searchtype =~ /start_with/o;
437
438
	my @columns_filtered= _filter_columns($tablename,$searchtype,$filtercolumns);
439
	my $columns= _get_columns($tablename);
440
	my (@values,@keys);
441
	foreach my $operand (@operands){
442
		my @localkeys;
443
		foreach my $field (@columns_filtered){
444
			my ($tmpkeys, $localvalues)=_Process_Operands($operand,"$tablename.$field",$searchtype,$columns);
445
			if ($tmpkeys){
446
				push @values,@$localvalues;
447
				push @localkeys,@$tmpkeys;
448
			}
449
		}
450
		my $sql= join (' OR ', @localkeys);
451
		push @keys, $sql;
452
	}
453
454
	if (@keys){
455
		return (\@keys,\@values);
456
	}
457
	else {
458
		return ();
459
	}
460
}
461
sub _Process_Operands{
462
	my ($operand, $field, $searchtype,$columns)=@_;
463
	my @values;
464
	my @tmpkeys;
465
	my @localkeys;
466
467
    $operand = [$operand] unless ref $operand eq 'ARRAY';
468
    foreach (@$operand) {
469
	    push @tmpkeys, " $field = ? ";
470
	    push @values, $_;
471
    }
472
	#By default, exact search
473
	if (!$searchtype ||$searchtype eq "exact"){
474
		return \@tmpkeys,\@values;
475
	}
476
	my $col_field=(index($field,".")>0?substr($field, index($field,".")+1):$field);
477
	if ($field=~/(?<!zip)code|(?<!card)number/ && $searchtype ne "exact"){
478
		push @tmpkeys,(" $field= '' ","$field IS NULL");
479
	}
480
	if ($columns->{$col_field}->{Type}=~/varchar|text/i){
481
		my @localvaluesextended;
482
		if ($searchtype eq "contain"){
483
            foreach (@$operand) {
484
			    push @tmpkeys,(" $field LIKE ? ");
485
			    push @localvaluesextended,("\%$_\%") ;
486
            }
487
		}
488
		if ($searchtype eq "field_start_with"){
489
            foreach (@$operand) {
490
			    push @tmpkeys,("$field LIKE ?");
491
			    push @localvaluesextended, ("$_\%") ;
492
            }
493
		}
494
		if ($searchtype eq "start_with"){
495
            foreach (@$operand) {
496
			    push @tmpkeys,("$field LIKE ?","$field LIKE ?");
497
			    push @localvaluesextended, ("$_\%", " $_\%") ;
498
            }
499
		}
500
		push @values,@localvaluesextended;
501
	}
502
	push @localkeys,qq{ (}.join(" OR ",@tmpkeys).qq{) };
503
	return (\@localkeys,\@values);
504
}
505
1;
506
(-)a/t/db_dependent/SQLHelper.t (-67 lines)
Lines 1-66 Link Here
1
#!/usr/bin/perl
2
#
3
# This Koha test module is a stub!
4
# Add more tests here!!!
5
6
use strict;
7
use warnings;
8
use YAML;
9
10
use C4::Debug;
11
use C4::SQLHelper qw(:all);
12
13
use Test::More tests => 20;
14
15
use_ok('C4::SQLHelper');
16
17
use C4::Category;
18
use C4::Branch;
19
my @categories=C4::Category->all;
20
my $insert;
21
ok(($insert=InsertInTable("branches",{branchcode=>"ZZZZ",branchname=>"Brancheinconnue",city=>" ",zipcode=>" "},1))==0,"AddBranch (Insert In Table with primary key defined)");
22
my $branches=C4::Branch::GetBranches;
23
my @branchcodes=keys %$branches;
24
my ($borrid, $borrtmp);
25
ok($borrid=InsertInTable("borrowers",{firstname=>"Jean",surname=>"Valjean",city=>" ",zipcode=>" ",email=>"email",categorycode=>$categories[0]->{categorycode}, branchcode=>$branchcodes[0]}),"Insert In Table");
26
$borrtmp=InsertInTable("borrowers",{firstname=>"Jean",surname=>"cocteau",city=>" ",zipcode=>" ",email=>"email",categorycode=>$categories[0]->{categorycode}, branchcode=>$branchcodes[0]});
27
ok(my $status=UpdateInTable("borrowers",{borrowernumber=>$borrid,firstname=>"Jean",surname=>"Valjean",city=>"Dampierre",zipcode=>" ",email=>"email", branchcode=>$branchcodes[1]}),"Update In Table");
28
my $borrowers=SearchInTable("borrowers");
29
ok(@$borrowers>0, "Search In Table All values");
30
$borrowers=SearchInTable("borrowers",{borrowernumber=>$borrid});
31
ok(@$borrowers==1, "Search In Table by primary key on table");
32
$borrowers=SearchInTable("borrowers",{firstname=>"Jean"});
33
ok(@$borrowers>0, "Search In Table hashref");
34
$borrowers=SearchInTable("borrowers",{firstname=>"Jean"},[{firstname=>1},{borrowernumber=>1}],undef, [qw(borrowernumber)]);
35
ok(($$borrowers[0]{borrowernumber} + 0) > ($$borrowers[1]{borrowernumber} + 0), "Search In Table Order");
36
$borrowers=SearchInTable("borrowers",{firstname=>"Jean"},[{surname=>0},{firstname=>1}], undef, [qw(firstname surname)]);
37
ok(uc($$borrowers[0]{surname}) lt uc($$borrowers[1]{surname}), "Search In Table Order");
38
$borrowers=SearchInTable("borrowers","Jean");
39
ok(@$borrowers>0, "Search In Table string");
40
#FIXME : When searching on All the fields of the table, seems to return Junk
41
eval{$borrowers=SearchInTable("borrowers","Jean Valjean",undef,undef,undef,[qw(firstname surname borrowernumber cardnumber)],"start_with")};
42
#eval{$borrowers=SearchInTable("borrowers","Jean Valjean",undef,undef,undef,undef,"start_with")};
43
# This would not be much efficient because of "numbers" special treatment : We return stuff if empty or '' as soon as search is NOT exact
44
# This behaviour is implemented because of branchcode and numbers can be null
45
$debug && warn Dump(@$borrowers);
46
ok(scalar(@$borrowers)==1 && !($@), "Search In Table does an implicit AND of all the words in strings");
47
$borrowers=SearchInTable("borrowers",["Valjean",{firstname=>"Jean"}]);
48
ok(@$borrowers>0, "Search In Table arrayref");
49
$borrowers=SearchInTable("borrowers",["Valjean",{firstname=>"Jean"}],undef,undef,[qw(borrowernumber)]);
50
ok(keys %{$$borrowers[0]} ==1, "Search In Table columns out limit");
51
$borrowers=SearchInTable("borrowers",["Valjean",{firstname=>"Jean"}],undef,undef,[qw(borrowernumber)],[qw(firstname surname title)]);
52
ok(@$borrowers>0, "Search In Table columns out limit to borrowernumber AND filter firstname surname title");
53
$borrowers=SearchInTable("borrowers",["Val",{firstname=>"Jean"}],undef,undef,[qw(borrowernumber)],[qw(surname)],"start_with");
54
ok(@$borrowers>0, "Search In Table columns filter surname  Val on a wide search found ");
55
$borrowers=eval{SearchInTable("borrowers",["Val",{member=>"Jean"}],undef,undef,[qw(borrowernumber)],[qw(firstname title)],"exact")};
56
ok(@$borrowers==0 && !($@), "Search In Table fails gracefully when no correct field passed in hash");
57
$borrowers=eval{SearchInTable("borrowers",["Jea"],undef,undef,undef,[qw(firstname surname borrowernumber)],"start_with")};
58
ok(@$borrowers>0 && !($@), "Search on simple value in firstname");
59
60
$status=DeleteInTable("borrowers",{borrowernumber=>$borrid});
61
ok($status>0 && !($@), "DeleteInTable OK");
62
$status=DeleteInTable("borrowers",{borrowernumber=>$borrtmp});
63
ok($status>0 && !($@), "DeleteInTable OK");
64
$status=DeleteInTable("branches", {branchcode => 'ZZZZ'});
65
ok($status>0 && !($@), "DeleteInTable (branch) OK");
66
67
- 

Return to bug 11385