C4/SQLHelper.pm

   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