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