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         };
  40
  41         memoize_memcached( '_get_columns',   memcached => $memcached, expire_time => 600000 );    #cache for 10 minutes
  42         memoize_memcached( 'GetPrimaryKeys', memcached => $memcached, expire_time => 600000 );    #cache for 10 minutes
  43     }
  44 };
  45
  46 BEGIN {
  47         # set the version for version checking
  48         $VERSION = 0.5;
  49         require Exporter;
  50         @ISA    = qw(Exporter);
  51 @EXPORT_OK=qw(
  52         InsertInTable
  53         DeleteInTable
  54         SearchInTable
  55         UpdateInTable
  56         GetPrimaryKeys
  57 );
  58         %EXPORT_TAGS = ( all =>[qw( InsertInTable DeleteInTable SearchInTable UpdateInTable GetPrimaryKeys)]
  59                                 );
  60 }
  61
  62 my $tablename;
  63 my $hashref;
  64
  65 =head1 NAME
  66
  67 C4::SQLHelper - Perl Module containing convenience functions for SQL Handling
  68
  69 =head1 SYNOPSIS
  70
  71 use C4::SQLHelper;
  72
  73 =head1 DESCRIPTION
  74
  75 This module contains routines for adding, modifying and Searching Data in MysqlDB
  76
  77 =head1 FUNCTIONS
  78
  79 =head2 SearchInTable
  80
  81   $hashref = &SearchInTable($tablename,$data, $orderby, $limit,
  82                       $columns_out, $filtercolumns, $searchtype);
  83
  84
  85 $tablename Name of the table (string)
  86
  87 $data may contain
  88         - string
  89
  90         - data_hashref : will be considered as an AND of all the data searched
  91
  92         - data_array_ref on hashrefs : Will be considered as an OR of Datahasref elements
  93
  94 $orderby is an arrayref of hashref with fieldnames as key and 0 or 1 as values (ASCENDING or DESCENDING order)
  95
  96 $limit is an array ref on 2 values in order to limit results to MIN..MAX
  97
  98 $columns_out is an array ref on field names is used to limit results on those fields (* by default)
  99
 100 $filtercolums is an array ref on field names : is used to limit expansion of research for strings
 101
 102 $searchtype is string Can be "start_with" or "exact"
 103
 104 This query builder is very limited, it should be replaced with DBIx::Class
 105 or similar  very soon
 106 Meanwhile adding support for special key '' in case of a data_hashref to
 107 support filters of type
 108
 109   ( f1 = a OR f2 = a ) AND fx = b AND fy = c
 110
 111 Call for the query above is:
 112
 113   SearchInTable($tablename, {'' => a, fx => b, fy => c}, $orderby, $limit,
 114                 $columns_out, [f1, f2], 'exact');
 115
 116 NOTE: Current implementation may remove parts of the iinput hashrefs. If that is a problem
 117 a copy needs to be created in _filter_fields() below
 118
 119 =cut
 120
 121 sub SearchInTable{
 122     my ($tablename,$filters,$orderby, $limit, $columns_out, $filter_columns,$searchtype) = @_;
 123         $searchtype||="exact";
 124     my $dbh      = C4::Context->dbh;
 125         $columns_out||=["*"];
 126     my $sql      = do { local $"=', ';
 127                 qq{ SELECT @$columns_out from $tablename}
 128                };
 129     my $row;
 130     my $sth;
 131     my ($keys,$values)=_filter_fields($tablename,$filters,$searchtype,$filter_columns);
 132         if ($keys){
 133                 my @criteria=grep{defined($_) && $_ !~/^\W$/ }@$keys;
 134                 if (@criteria) {
 135                         $sql.= do { local $"=') OR (';
 136                                         qq{ WHERE (@criteria) }
 137                                    };
 138                 }
 139         }
 140     if ($orderby){
 141                 #Order by desc by default
 142                 my @orders;
 143                 foreach my $order ( ref($orderby) ? @$orderby : $orderby ){
 144             if (ref $order) {
 145                             push @orders,map{ "$_".($order->{$_}? " DESC " : "") } keys %$order;
 146             } else {
 147                             push @orders,$order;
 148             }
 149                 }
 150                 $sql.= do { local $"=', ';
 151                                 qq{ ORDER BY @orders}
 152         };
 153     }
 154         if ($limit){
 155                 $sql.=qq{ LIMIT }.join(",",@$limit);
 156         }
 157
 158     $debug && $values && warn $sql," ",join(",",@$values);
 159     $sth = $dbh->prepare_cached($sql);
 160     eval{$sth->execute(@$values)};
 161         warn $@ if ($@ && $debug);
 162     my $results = $sth->fetchall_arrayref( {} );
 163     return $results;
 164 }
 165
 166 =head2 InsertInTable
 167
 168   $data_id_in_table = &InsertInTable($tablename,$data_hashref,$withprimarykeys);
 169
 170 Insert Data in table and returns the id of the row inserted
 171
 172 =cut
 173
 174 sub InsertInTable{
 175     my ($tablename,$data,$withprimarykeys) = @_;
 176     my $dbh      = C4::Context->dbh;
 177     my ($keys,$values)=_filter_hash($tablename,$data,($withprimarykeys?"exact":0));
 178     my $query = qq{ INSERT INTO $tablename SET  }.join(", ",@$keys);
 179
 180         $debug && warn $query, join(",",@$values);
 181     my $sth = $dbh->prepare_cached($query);
 182     eval{$sth->execute(@$values)};
 183         warn $@ if ($@ && $debug);
 184
 185         return $dbh->last_insert_id(undef, undef, $tablename, undef);
 186 }
 187
 188 =head2 UpdateInTable
 189
 190   $status = &UpdateInTable($tablename,$data_hashref);
 191
 192 Update Data in table and returns the status of the operation
 193
 194 =cut
 195
 196 sub UpdateInTable{
 197     my ($tablename,$data) = @_;
 198         my @field_ids=GetPrimaryKeys($tablename);
 199     my @ids=@$data{@field_ids};
 200     my $dbh      = C4::Context->dbh;
 201     my ($keys,$values)=_filter_hash($tablename,$data,0);
 202     return unless ($keys);
 203     my $query =
 204     qq{     UPDATE $tablename
 205             SET  }.join(",",@$keys).qq{
 206             WHERE }.join (" AND ",map{ "$_=?" }@field_ids);
 207         $debug && warn $query, join(",",@$values,@ids);
 208
 209     my $sth = $dbh->prepare_cached($query);
 210         my $result;
 211     eval{$result=$sth->execute(@$values,@ids)};
 212         warn $@ if ($@ && $debug);
 213     return $result;
 214 }
 215
 216 =head2 DeleteInTable
 217
 218   $status = &DeleteInTable($tablename,$data_hashref);
 219
 220 Delete Data in table and returns the status of the operation
 221
 222 =cut
 223
 224 sub DeleteInTable{
 225     my ($tablename,$data) = @_;
 226     my $dbh      = C4::Context->dbh;
 227     my ($keys,$values)=_filter_fields($tablename,$data,1);
 228         if ($keys){
 229                 my $query = do { local $"=') AND (';
 230                 qq{ DELETE FROM $tablename WHERE (@$keys)};
 231                 };
 232                 $debug && warn $query, join(",",@$values);
 233                 my $sth = $dbh->prepare_cached($query);
 234                 my $result;
 235         eval{$result=$sth->execute(@$values)};
 236                 warn $@ if ($@ && $debug);
 237         return $result;
 238         }
 239 }
 240
 241 =head2 GetPrimaryKeys
 242
 243   @primarykeys = &GetPrimaryKeys($tablename)
 244
 245 Get the Primary Key field names of the table
 246
 247 =cut
 248
 249 sub GetPrimaryKeys($) {
 250         my $tablename=shift;
 251         my $hash_columns=_get_columns($tablename);
 252         return  grep { $hash_columns->{$_}->{'Key'} =~/PRI/i}  keys %$hash_columns;
 253 }
 254
 255 =head2 _get_columns
 256
 257     _get_columns($tablename)
 258
 259 Given a tablename
 260 Returns a hashref of all the fieldnames of the table
 261 With
 262         Key
 263         Type
 264         Default
 265
 266 =cut
 267
 268 sub _get_columns($) {
 269     my ($tablename) = @_;
 270     unless ( exists( $hashref->{$tablename} ) ) {
 271         my $dbh = C4::Context->dbh;
 272         my $sth = $dbh->prepare_cached(qq{SHOW COLUMNS FROM $tablename });
 273         $sth->execute;
 274         my $columns = $sth->fetchall_hashref(qw(Field));
 275         $hashref->{$tablename} = $columns;
 276     }
 277     return $hashref->{$tablename};
 278 }
 279
 280 =head2 _filter_columns
 281
 282 =over 4
 283
 284 _filter_columns($tablename,$research, $filtercolumns)
 285
 286 =back
 287
 288 Given
 289         - a tablename
 290         - indicator on purpose whether all fields should be returned or only non Primary keys
 291         - array_ref to columns to limit to
 292
 293 Returns an array of all the fieldnames of the table
 294 If it is not for research purpose, filter primary keys
 295
 296 =cut
 297
 298 sub _filter_columns ($$;$) {
 299         my ($tablename,$research, $filtercolumns)=@_;
 300         if ($filtercolumns){
 301                 return (@$filtercolumns);
 302         }
 303         else {
 304                 my $columns=_get_columns($tablename);
 305                 if ($research){
 306                         return keys %$columns;
 307                 }
 308                 else {
 309                         return grep {my $column=$_; any {$_ ne $column }GetPrimaryKeys($tablename) } keys %$columns;
 310                 }
 311         }
 312 }
 313 =head2 _filter_fields
 314
 315   _filter_fields
 316
 317 Given
 318         - a tablename
 319         - a string or a hashref (containing, fieldnames and datatofilter) or an arrayref to one of those elements
 320         - an indicator of operation whether it is a wide research or a narrow one
 321         - an array ref to columns to restrict string filter to.
 322
 323 Returns a ref of key array to use in SQL functions
 324 and a ref to value array
 325
 326 =cut
 327
 328 sub _filter_fields{
 329         my ($tablename,$filter_input,$searchtype,$filtercolumns)=@_;
 330     my @keys;
 331         my @values;
 332         if (ref($filter_input) eq "HASH"){
 333                 my ($keys, $values);
 334         if (my $special = delete $filter_input->{''}) { # XXX destroyes '' key
 335                     ($keys, $values) = _filter_fields($tablename,$special, $searchtype,$filtercolumns);
 336         }
 337                 my ($hkeys, $hvalues) = _filter_hash($tablename,$filter_input, $searchtype);
 338                 if ($hkeys){
 339             push @$keys, @$hkeys;
 340             push @$values, @$hvalues;
 341         }
 342                 if ($keys){
 343                     my $stringkey="(".join (") AND (",@$keys).")";
 344                     return [$stringkey],$values;
 345                 }
 346                 else {
 347                     return ();
 348                 }
 349         } elsif (ref($filter_input) eq "ARRAY"){
 350                 foreach my $element_data (@$filter_input){
 351                         my ($localkeys,$localvalues)=_filter_fields($tablename,$element_data,$searchtype,$filtercolumns);
 352                         if ($localkeys){
 353                                 @$localkeys=grep{defined($_) && $_ !~/^\W*$/}@$localkeys;
 354                                 my $string=do{
 355                                                                 local $"=") OR (";
 356                                                                 qq{(@$localkeys)}
 357                                                         };
 358                                 push @keys, $string;
 359                                 push @values, @$localvalues;
 360                         }
 361                 }
 362         }
 363         else{
 364         $debug && warn "filterstring : $filter_input";
 365                 my ($keys, $values) = _filter_string($tablename,$filter_input, $searchtype,$filtercolumns);
 366                 if ($keys){
 367                 my $stringkey="(".join (") AND (",@$keys).")";
 368                 return [$stringkey],$values;
 369                 }
 370                 else {
 371                 return ();
 372                 }
 373         }
 374
 375         return (\@keys,\@values);
 376 }
 377
 378 sub _filter_hash{
 379         my ($tablename,$filter_input, $searchtype)=@_;
 380         my (@values, @keys);
 381         my $columns= _get_columns($tablename);
 382         my @columns_filtered= _filter_columns($tablename,$searchtype);
 383
 384         #Filter Primary Keys of table
 385     my $elements=join "|",@columns_filtered;
 386         foreach my $field (grep {/\b($elements)\b/} keys %$filter_input){
 387                 ## supposed to be a hash of simple values, hashes of arrays could be implemented
 388                 $filter_input->{$field}=format_date_in_iso($filter_input->{$field})
 389           if $columns->{$field}{Type}=~/date/ &&
 390              $filter_input->{$field} !~C4::Dates->regexp("iso");
 391                 my ($tmpkeys, $localvalues)=_Process_Operands($filter_input->{$field},"$tablename.$field",$searchtype,$columns);
 392                 if (@$tmpkeys){
 393                         push @values, @$localvalues;
 394                         push @keys, @$tmpkeys;
 395                 }
 396         }
 397         if (@keys){
 398                 return (\@keys,\@values);
 399         }
 400         else {
 401                 return ();
 402         }
 403 }
 404
 405 sub _filter_string{
 406         my ($tablename,$filter_input, $searchtype,$filtercolumns)=@_;
 407         return () unless($filter_input);
 408         my @operands=split /\s+/,$filter_input;
 409
 410     # An act of desperation
 411     $searchtype = 'contain' if @operands > 1 && $searchtype =~ /start_with/o;
 412
 413         my @columns_filtered= _filter_columns($tablename,$searchtype,$filtercolumns);
 414         my $columns= _get_columns($tablename);
 415         my (@values,@keys);
 416         foreach my $operand (@operands){
 417                 my @localkeys;
 418                 foreach my $field (@columns_filtered){
 419                         my ($tmpkeys, $localvalues)=_Process_Operands($operand,"$tablename.$field",$searchtype,$columns);
 420                         if ($tmpkeys){
 421                                 push @values,@$localvalues;
 422                                 push @localkeys,@$tmpkeys;
 423                         }
 424                 }
 425                 my $sql= join (' OR ', @localkeys);
 426                 push @keys, $sql;
 427         }
 428
 429         if (@keys){
 430                 return (\@keys,\@values);
 431         }
 432         else {
 433                 return ();
 434         }
 435 }
 436 sub _Process_Operands{
 437         my ($operand, $field, $searchtype,$columns)=@_;
 438         my @values;
 439         my @tmpkeys;
 440         my @localkeys;
 441
 442     $operand = [$operand] unless ref $operand eq 'ARRAY';
 443     foreach (@$operand) {
 444             push @tmpkeys, " $field = ? ";
 445             push @values, $_;
 446     }
 447         #By default, exact search
 448         if (!$searchtype ||$searchtype eq "exact"){
 449                 return \@tmpkeys,\@values;
 450         }
 451         my $col_field=(index($field,".")>0?substr($field, index($field,".")+1):$field);
 452         if ($field=~/(?<!zip)code|(?<!card)number/ && $searchtype ne "exact"){
 453                 push @tmpkeys,(" $field= '' ","$field IS NULL");
 454         }
 455         if ($columns->{$col_field}->{Type}=~/varchar|text/i){
 456                 my @localvaluesextended;
 457                 if ($searchtype eq "contain"){
 458             foreach (@$operand) {
 459                             push @tmpkeys,(" $field LIKE ? ");
 460                             push @localvaluesextended,("\%$_\%") ;
 461             }
 462                 }
 463                 if ($searchtype eq "field_start_with"){
 464             foreach (@$operand) {
 465                             push @tmpkeys,("$field LIKE ?");
 466                             push @localvaluesextended, ("$_\%") ;
 467             }
 468                 }
 469                 if ($searchtype eq "start_with"){
 470             foreach (@$operand) {
 471                             push @tmpkeys,("$field LIKE ?","$field LIKE ?");
 472                             push @localvaluesextended, ("$_\%", " $_\%") ;
 473             }
 474                 }
 475                 push @values,@localvaluesextended;
 476         }
 477         push @localkeys,qq{ (}.join(" OR ",@tmpkeys).qq{) };
 478         return (\@localkeys,\@values);
 479 }
 480 1;
 481