File: | C4/SQLHelper.pm |
Coverage: | 9.3% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
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 | 17 17 17 | 105 98 1212 | use strict; | |||
22 | 17 17 17 | 188 108 885 | use warnings; | |||
23 | 17 17 17 | 661 3296 1923 | use List::MoreUtils qw(first_value any); | |||
24 | 17 17 17 | 398 167 345 | use C4::Context; | |||
25 | 17 17 17 | 261 206 915 | use C4::Dates qw(format_date_in_iso); | |||
26 | 17 17 17 | 117 57 1685 | use C4::Debug; | |||
27 | require Exporter; | |||||
28 | 17 17 17 | 112 87 4450 | 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 | 17 | 61 | $VERSION = 0.5; | |||
50 | 17 | 139 | require Exporter; | |||
51 | 17 | 213 | @ISA = qw(Exporter); | |||
52 | 17 | 97 | @EXPORT_OK=qw( | |||
53 | InsertInTable | |||||
54 | DeleteInTable | |||||
55 | SearchInTable | |||||
56 | UpdateInTable | |||||
57 | GetPrimaryKeys | |||||
58 | clear_columns_cache | |||||
59 | ); | |||||
60 | 17 | 50390 | %EXPORT_TAGS = ( all =>[qw( InsertInTable DeleteInTable SearchInTable UpdateInTable GetPrimaryKeys)] | |||
61 | ); | |||||
62 | } | |||||
63 | ||||||
64 | my $tablename; | |||||
65 | my $hashref; | |||||
66 | ||||||
67 - 121 | =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 | |||||
122 | ||||||
123 | sub SearchInTable{ | |||||
124 | 0 | my ($tablename,$filters,$orderby, $limit, $columns_out, $filter_columns,$searchtype) = @_; | ||||
125 | 0 | $searchtype||="exact"; | ||||
126 | 0 | my $dbh = C4::Context->dbh; | ||||
127 | 0 | $columns_out||=["*"]; | ||||
128 | 0 0 | my $sql = do { local $"=', '; | ||||
129 | 0 | qq{ SELECT @$columns_out from $tablename} | ||||
130 | }; | |||||
131 | 0 | my $row; | ||||
132 | 0 | my $sth; | ||||
133 | 0 | my ($keys,$values)=_filter_fields($tablename,$filters,$searchtype,$filter_columns); | ||||
134 | 0 | if ($keys){ | ||||
135 | 0 0 | my @criteria=grep{defined($_) && $_ !~/^\W$/ }@$keys; | ||||
136 | 0 | if (@criteria) { | ||||
137 | 0 0 | $sql.= do { local $"=') OR ('; | ||||
138 | 0 | qq{ WHERE (@criteria) } | ||||
139 | }; | |||||
140 | } | |||||
141 | } | |||||
142 | 0 | if ($orderby){ | ||||
143 | #Order by desc by default | |||||
144 | 0 | my @orders; | ||||
145 | 0 | foreach my $order ( ref($orderby) ? @$orderby : $orderby ){ | ||||
146 | 0 | if (ref $order) { | ||||
147 | 0 0 | push @orders,map{ "$_".($order->{$_}? " DESC " : "") } keys %$order; | ||||
148 | } else { | |||||
149 | 0 | push @orders,$order; | ||||
150 | } | |||||
151 | } | |||||
152 | 0 0 | $sql.= do { local $"=', '; | ||||
153 | 0 | qq{ ORDER BY @orders} | ||||
154 | }; | |||||
155 | } | |||||
156 | 0 | if ($limit){ | ||||
157 | 0 | $sql.=qq{ LIMIT }.join(",",@$limit); | ||||
158 | } | |||||
159 | ||||||
160 | 0 | $debug && $values && warn $sql," ",join(",",@$values); | ||||
161 | 0 | $sth = $dbh->prepare_cached($sql); | ||||
162 | 0 0 | eval{$sth->execute(@$values)}; | ||||
163 | 0 | warn $@ if ($@ && $debug); | ||||
164 | 0 | my $results = $sth->fetchall_arrayref( {} ); | ||||
165 | 0 | return $results; | ||||
166 | } | |||||
167 | ||||||
168 - 174 | =head2 InsertInTable $data_id_in_table = &InsertInTable($tablename,$data_hashref,$withprimarykeys); Insert Data in table and returns the id of the row inserted =cut | |||||
175 | ||||||
176 | sub InsertInTable{ | |||||
177 | 0 | my ($tablename,$data,$withprimarykeys) = @_; | ||||
178 | 0 | my $dbh = C4::Context->dbh; | ||||
179 | 0 | my ($keys,$values)=_filter_hash($tablename,$data,($withprimarykeys?"exact":0)); | ||||
180 | 0 | my $query = qq{ INSERT INTO $tablename SET }.join(", ",@$keys); | ||||
181 | ||||||
182 | 0 | $debug && warn $query, join(",",@$values); | ||||
183 | 0 | my $sth = $dbh->prepare_cached($query); | ||||
184 | 0 0 | eval{$sth->execute(@$values)}; | ||||
185 | 0 | warn $@ if ($@ && $debug); | ||||
186 | ||||||
187 | 0 | return $dbh->last_insert_id(undef, undef, $tablename, undef); | ||||
188 | } | |||||
189 | ||||||
190 - 196 | =head2 UpdateInTable $status = &UpdateInTable($tablename,$data_hashref); Update Data in table and returns the status of the operation =cut | |||||
197 | ||||||
198 | sub UpdateInTable{ | |||||
199 | 0 | my ($tablename,$data) = @_; | ||||
200 | 0 | my @field_ids=GetPrimaryKeys($tablename); | ||||
201 | 0 | my @ids=@$data{@field_ids}; | ||||
202 | 0 | my $dbh = C4::Context->dbh; | ||||
203 | 0 | my ($keys,$values)=_filter_hash($tablename,$data,0); | ||||
204 | 0 | return unless ($keys); | ||||
205 | 0 | my $query = | ||||
206 | qq{ UPDATE $tablename | |||||
207 | SET }.join(",",@$keys).qq{ | |||||
208 | 0 | WHERE }.join (" AND ",map{ "$_=?" }@field_ids); | ||||
209 | 0 | $debug && warn $query, join(",",@$values,@ids); | ||||
210 | ||||||
211 | 0 | my $sth = $dbh->prepare_cached($query); | ||||
212 | 0 | my $result; | ||||
213 | 0 0 | eval{$result=$sth->execute(@$values,@ids)}; | ||||
214 | 0 | warn $@ if ($@ && $debug); | ||||
215 | 0 | return $result; | ||||
216 | } | |||||
217 | ||||||
218 - 224 | =head2 DeleteInTable $status = &DeleteInTable($tablename,$data_hashref); Delete Data in table and returns the status of the operation =cut | |||||
225 | ||||||
226 | sub DeleteInTable{ | |||||
227 | 0 | my ($tablename,$data) = @_; | ||||
228 | 0 | my $dbh = C4::Context->dbh; | ||||
229 | 0 | my ($keys,$values)=_filter_fields($tablename,$data,1); | ||||
230 | 0 | if ($keys){ | ||||
231 | 0 0 | my $query = do { local $"=') AND ('; | ||||
232 | 0 | qq{ DELETE FROM $tablename WHERE (@$keys)}; | ||||
233 | }; | |||||
234 | 0 | $debug && warn $query, join(",",@$values); | ||||
235 | 0 | my $sth = $dbh->prepare_cached($query); | ||||
236 | 0 | my $result; | ||||
237 | 0 0 | eval{$result=$sth->execute(@$values)}; | ||||
238 | 0 | warn $@ if ($@ && $debug); | ||||
239 | 0 | return $result; | ||||
240 | } | |||||
241 | } | |||||
242 | ||||||
243 - 249 | =head2 GetPrimaryKeys @primarykeys = &GetPrimaryKeys($tablename) Get the Primary Key field names of the table =cut | |||||
250 | ||||||
251 | sub GetPrimaryKeys($) { | |||||
252 | 0 | my $tablename=shift; | ||||
253 | 0 | my $hash_columns=_get_columns($tablename); | ||||
254 | 0 0 | return grep { $hash_columns->{$_}->{'Key'} =~/PRI/i} keys %$hash_columns; | ||||
255 | } | |||||
256 | ||||||
257 | ||||||
258 - 266 | =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 | |||||
267 | ||||||
268 | sub clear_columns_cache { | |||||
269 | 0 | %$hashref = (); | ||||
270 | } | |||||
271 | ||||||
272 | ||||||
273 | ||||||
274 - 285 | =head2 _get_columns _get_columns($tablename) Given a tablename Returns a hashref of all the fieldnames of the table With Key Type Default =cut | |||||
286 | ||||||
287 | sub _get_columns($) { | |||||
288 | 0 | my ($tablename) = @_; | ||||
289 | 0 | unless ( exists( $hashref->{$tablename} ) ) { | ||||
290 | 0 | my $dbh = C4::Context->dbh; | ||||
291 | 0 | my $sth = $dbh->prepare_cached(qq{SHOW COLUMNS FROM $tablename }); | ||||
292 | 0 | $sth->execute; | ||||
293 | 0 | my $columns = $sth->fetchall_hashref(qw(Field)); | ||||
294 | 0 | $hashref->{$tablename} = $columns; | ||||
295 | } | |||||
296 | 0 | return $hashref->{$tablename}; | ||||
297 | } | |||||
298 | ||||||
299 - 315 | =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 | |||||
316 | ||||||
317 | sub _filter_columns ($$;$) { | |||||
318 | 0 | my ($tablename,$research, $filtercolumns)=@_; | ||||
319 | 0 | if ($filtercolumns){ | ||||
320 | 0 | return (@$filtercolumns); | ||||
321 | } | |||||
322 | else { | |||||
323 | 0 | my $columns=_get_columns($tablename); | ||||
324 | 0 | if ($research){ | ||||
325 | 0 | return keys %$columns; | ||||
326 | } | |||||
327 | else { | |||||
328 | 0 0 0 0 | return grep {my $column=$_; any {$_ ne $column }GetPrimaryKeys($tablename) } keys %$columns; | ||||
329 | } | |||||
330 | } | |||||
331 | } | |||||
332 - 345 | =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 | |||||
346 | ||||||
347 | sub _filter_fields{ | |||||
348 | 0 | my ($tablename,$filter_input,$searchtype,$filtercolumns)=@_; | ||||
349 | 0 | my @keys; | ||||
350 | 0 | my @values; | ||||
351 | 0 | if (ref($filter_input) eq "HASH"){ | ||||
352 | 0 | my ($keys, $values); | ||||
353 | 0 | if (my $special = delete $filter_input->{''}) { # XXX destroyes '' key | ||||
354 | 0 | ($keys, $values) = _filter_fields($tablename,$special, $searchtype,$filtercolumns); | ||||
355 | } | |||||
356 | 0 | my ($hkeys, $hvalues) = _filter_hash($tablename,$filter_input, $searchtype); | ||||
357 | 0 | if ($hkeys){ | ||||
358 | 0 | push @$keys, @$hkeys; | ||||
359 | 0 | push @$values, @$hvalues; | ||||
360 | } | |||||
361 | 0 | if ($keys){ | ||||
362 | 0 | my $stringkey="(".join (") AND (",@$keys).")"; | ||||
363 | 0 | return [$stringkey],$values; | ||||
364 | } | |||||
365 | else { | |||||
366 | 0 | return (); | ||||
367 | } | |||||
368 | } elsif (ref($filter_input) eq "ARRAY"){ | |||||
369 | 0 | foreach my $element_data (@$filter_input){ | ||||
370 | 0 | my ($localkeys,$localvalues)=_filter_fields($tablename,$element_data,$searchtype,$filtercolumns); | ||||
371 | 0 | if ($localkeys){ | ||||
372 | 0 0 | @$localkeys=grep{defined($_) && $_ !~/^\W*$/}@$localkeys; | ||||
373 | 0 | my $string=do{ | ||||
374 | 0 | local $"=") OR ("; | ||||
375 | 0 | qq{(@$localkeys)} | ||||
376 | }; | |||||
377 | 0 | push @keys, $string; | ||||
378 | 0 | push @values, @$localvalues; | ||||
379 | } | |||||
380 | } | |||||
381 | } | |||||
382 | else{ | |||||
383 | 0 | $debug && warn "filterstring : $filter_input"; | ||||
384 | 0 | my ($keys, $values) = _filter_string($tablename,$filter_input, $searchtype,$filtercolumns); | ||||
385 | 0 | if ($keys){ | ||||
386 | 0 | my $stringkey="(".join (") AND (",@$keys).")"; | ||||
387 | 0 | return [$stringkey],$values; | ||||
388 | } | |||||
389 | else { | |||||
390 | 0 | return (); | ||||
391 | } | |||||
392 | } | |||||
393 | ||||||
394 | 0 | return (\@keys,\@values); | ||||
395 | } | |||||
396 | ||||||
397 | sub _filter_hash{ | |||||
398 | 0 | my ($tablename,$filter_input, $searchtype)=@_; | ||||
399 | 0 | my (@values, @keys); | ||||
400 | 0 | my $columns= _get_columns($tablename); | ||||
401 | 0 | my @columns_filtered= _filter_columns($tablename,$searchtype); | ||||
402 | ||||||
403 | #Filter Primary Keys of table | |||||
404 | 0 | my $elements=join "|",@columns_filtered; | ||||
405 | 0 0 | 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 | 0 | $filter_input->{$field}=format_date_in_iso($filter_input->{$field}) | ||||
408 | if $columns->{$field}{Type}=~/date/ && | |||||
409 | $filter_input->{$field} !~C4::Dates->regexp("iso"); | |||||
410 | 0 | my ($tmpkeys, $localvalues)=_Process_Operands($filter_input->{$field},"$tablename.$field",$searchtype,$columns); | ||||
411 | 0 | if (@$tmpkeys){ | ||||
412 | 0 | push @values, @$localvalues; | ||||
413 | 0 | push @keys, @$tmpkeys; | ||||
414 | } | |||||
415 | } | |||||
416 | 0 | if (@keys){ | ||||
417 | 0 | return (\@keys,\@values); | ||||
418 | } | |||||
419 | else { | |||||
420 | 0 | return (); | ||||
421 | } | |||||
422 | } | |||||
423 | ||||||
424 | sub _filter_string{ | |||||
425 | 0 | my ($tablename,$filter_input, $searchtype,$filtercolumns)=@_; | ||||
426 | 0 | return () unless($filter_input); | ||||
427 | 0 | my @operands=split /\s+/,$filter_input; | ||||
428 | ||||||
429 | # An act of desperation | |||||
430 | 0 | $searchtype = 'contain' if @operands > 1 && $searchtype =~ /start_with/o; | ||||
431 | ||||||
432 | 0 | my @columns_filtered= _filter_columns($tablename,$searchtype,$filtercolumns); | ||||
433 | 0 | my $columns= _get_columns($tablename); | ||||
434 | 0 | my (@values,@keys); | ||||
435 | 0 | foreach my $operand (@operands){ | ||||
436 | 0 | my @localkeys; | ||||
437 | 0 | foreach my $field (@columns_filtered){ | ||||
438 | 0 | my ($tmpkeys, $localvalues)=_Process_Operands($operand,"$tablename.$field",$searchtype,$columns); | ||||
439 | 0 | if ($tmpkeys){ | ||||
440 | 0 | push @values,@$localvalues; | ||||
441 | 0 | push @localkeys,@$tmpkeys; | ||||
442 | } | |||||
443 | } | |||||
444 | 0 | my $sql= join (' OR ', @localkeys); | ||||
445 | 0 | push @keys, $sql; | ||||
446 | } | |||||
447 | ||||||
448 | 0 | if (@keys){ | ||||
449 | 0 | return (\@keys,\@values); | ||||
450 | } | |||||
451 | else { | |||||
452 | 0 | return (); | ||||
453 | } | |||||
454 | } | |||||
455 | sub _Process_Operands{ | |||||
456 | 0 | my ($operand, $field, $searchtype,$columns)=@_; | ||||
457 | 0 | my @values; | ||||
458 | 0 | my @tmpkeys; | ||||
459 | 0 | my @localkeys; | ||||
460 | ||||||
461 | 0 | $operand = [$operand] unless ref $operand eq 'ARRAY'; | ||||
462 | 0 | foreach (@$operand) { | ||||
463 | 0 | push @tmpkeys, " $field = ? "; | ||||
464 | 0 | push @values, $_; | ||||
465 | } | |||||
466 | #By default, exact search | |||||
467 | 0 | if (!$searchtype ||$searchtype eq "exact"){ | ||||
468 | 0 | return \@tmpkeys,\@values; | ||||
469 | } | |||||
470 | 0 | my $col_field=(index($field,".")>0?substr($field, index($field,".")+1):$field); | ||||
471 | 0 | if ($field=~/(?<!zip)code|(?<!card)number/ && $searchtype ne "exact"){ | ||||
472 | 0 | push @tmpkeys,(" $field= '' ","$field IS NULL"); | ||||
473 | } | |||||
474 | 0 | if ($columns->{$col_field}->{Type}=~/varchar|text/i){ | ||||
475 | 0 | my @localvaluesextended; | ||||
476 | 0 | if ($searchtype eq "contain"){ | ||||
477 | 0 | foreach (@$operand) { | ||||
478 | 0 | push @tmpkeys,(" $field LIKE ? "); | ||||
479 | 0 | push @localvaluesextended,("\%$_\%") ; | ||||
480 | } | |||||
481 | } | |||||
482 | 0 | if ($searchtype eq "field_start_with"){ | ||||
483 | 0 | foreach (@$operand) { | ||||
484 | 0 | push @tmpkeys,("$field LIKE ?"); | ||||
485 | 0 | push @localvaluesextended, ("$_\%") ; | ||||
486 | } | |||||
487 | } | |||||
488 | 0 | if ($searchtype eq "start_with"){ | ||||
489 | 0 | foreach (@$operand) { | ||||
490 | 0 | push @tmpkeys,("$field LIKE ?","$field LIKE ?"); | ||||
491 | 0 | push @localvaluesextended, ("$_\%", " $_\%") ; | ||||
492 | } | |||||
493 | } | |||||
494 | 0 | push @values,@localvaluesextended; | ||||
495 | } | |||||
496 | 0 | push @localkeys,qq{ (}.join(" OR ",@tmpkeys).qq{) }; | ||||
497 | 0 | return (\@localkeys,\@values); | ||||
498 | } | |||||
499 | 1; | |||||
500 |