SL/DBUtils.pm

   1 package SL::DBUtils;
   2
   3 use SL::Util qw(trim);
   4
   5 require Exporter;
   6 our @ISA = qw(Exporter);
   7
   8 our @EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement
   9              dump_query quote_db_date
  10              selectfirst_hashref_query selectfirst_array_query
  11              selectall_hashref_query selectall_array_query
  12              selectall_as_map
  13              selectall_ids
  14              prepare_execute_query prepare_query
  15              create_sort_spec does_table_exist
  16              add_token);
  17
  18 use strict;
  19
  20 sub conv_i {
  21   my ($value, $default) = @_;
  22   return (defined($value) && "$value" ne "") ? $value * 1 : $default;
  23 }
  24
  25 # boolean escape
  26 sub conv_b {
  27   my ($value, $default) = @_;
  28   return !defined $value && defined $default ? $default
  29        :          $value                     ? 't'
  30        :                                       'f';
  31 }
  32
  33 sub conv_date {
  34   my ($value) = @_;
  35   return undef if !defined $value;
  36   $value = trim($value);
  37   return $value eq "" ? undef : $value;
  38 }
  39
  40 sub conv_dateq {
  41   my ($value) = @_;
  42   if (defined($value) && "$value" ne "") {
  43     $value =~ s/\'/\'\'/g;
  44     return "'$value'";
  45   }
  46   return "NULL";
  47 }
  48
  49 sub do_query {
  50   $main::lxdebug->enter_sub(2);
  51
  52   my ($form, $dbh, $query) = splice(@_, 0, 3);
  53
  54   dump_query(LXDebug->QUERY(), '', $query, @_);
  55
  56   my $result;
  57   if (0 == scalar(@_)) {
  58     $result = $dbh->do($query)            || $form->dberror($query);
  59   } else {
  60     $result = $dbh->do($query, undef, @_) || $form->dberror($query . " (" . join(", ", @_) . ")");
  61   }
  62
  63   $main::lxdebug->leave_sub(2);
  64
  65   return $result;
  66 }
  67
  68 sub selectrow_query { &selectfirst_array_query }
  69
  70 sub do_statement {
  71   $main::lxdebug->enter_sub(2);
  72
  73   my ($form, $sth, $query) = splice(@_, 0, 3);
  74
  75   dump_query(LXDebug->QUERY(), '', $query, @_);
  76
  77   my $result;
  78   if (0 == scalar(@_)) {
  79     $result = $sth->execute()   || $form->dberror($query);
  80   } else {
  81     $result = $sth->execute(@_) || $form->dberror($query . " (" . join(", ", @_) . ")");
  82   }
  83
  84   $main::lxdebug->leave_sub(2);
  85
  86   return $result;
  87 }
  88
  89 sub dump_query {
  90   my ($level, $msg, $query) = splice(@_, 0, 3);
  91
  92   my $self_filename = 'SL/DBUtils.pm';
  93   my $filename      = $self_filename;
  94   my ($caller_level, $line, $subroutine);
  95   while ($filename eq $self_filename) {
  96     (undef, $filename, $line, $subroutine) = caller $caller_level++;
  97   }
  98
  99   while ($query =~ /\?/) {
 100     my $value = shift || '';
 101     $value =~ s/\'/\\\'/g;
 102     $value = "'${value}'";
 103     $query =~ s/\?/$value/;
 104   }
 105
 106   $query =~ s/[\n\s]+/ /g;
 107
 108   $msg .= " " if ($msg);
 109
 110   my $info = "$subroutine called from $filename:$line\n";
 111
 112   $main::lxdebug->message($level, $info . $msg . $query);
 113 }
 114
 115 sub quote_db_date {
 116   my ($str) = @_;
 117
 118   return "NULL" unless defined $str;
 119   return "current_date" if $str =~ /current_date/;
 120
 121   $str =~ s/\'/\'\'/g;
 122   return "'$str'";
 123 }
 124
 125 sub prepare_query {
 126   $main::lxdebug->enter_sub(2);
 127
 128   my ($form, $dbh, $query) = splice(@_, 0, 3);
 129
 130   dump_query(LXDebug->QUERY(), '', $query, @_);
 131
 132   my $sth = $dbh->prepare($query) || $form->dberror($query);
 133
 134   $main::lxdebug->leave_sub(2);
 135
 136   return $sth;
 137 }
 138
 139 sub prepare_execute_query {
 140   $main::lxdebug->enter_sub(2);
 141
 142   my ($form, $dbh, $query) = splice(@_, 0, 3);
 143
 144   dump_query(LXDebug->QUERY(), '', $query, @_);
 145
 146   my $sth = $dbh->prepare($query) || $form->dberror($query);
 147   if (scalar(@_) != 0) {
 148     $sth->execute(@_) || $form->dberror($query . " (" . join(", ", @_) . ")");
 149   } else {
 150     $sth->execute() || $form->dberror($query);
 151   }
 152
 153   $main::lxdebug->leave_sub(2);
 154
 155   return $sth;
 156 }
 157
 158 sub selectall_hashref_query {
 159   $main::lxdebug->enter_sub(2);
 160
 161   my ($form, $dbh, $query) = splice(@_, 0, 3);
 162
 163   dump_query(LXDebug->QUERY(), '', $query, @_);
 164
 165   # this works back 'til at least DBI 1.46 on perl 5.8.4 on Debian Sarge (2004)
 166   my $result = $dbh->selectall_arrayref($query, { Slice => {} }, @_)
 167     or $form->dberror($query . (@_ ? " (" . join(", ", @_) . ")" : ''));
 168
 169   $main::lxdebug->leave_sub(2);
 170
 171   return wantarray ? @{ $result } : $result;
 172 }
 173
 174 sub selectall_array_query {
 175   $main::lxdebug->enter_sub(2);
 176
 177   my ($form, $dbh, $query) = splice(@_, 0, 3);
 178
 179   my $sth = prepare_execute_query($form, $dbh, $query, @_);
 180   my @result;
 181   while (my ($value) = $sth->fetchrow_array()) {
 182     push(@result, $value);
 183   }
 184   $sth->finish();
 185
 186   $main::lxdebug->leave_sub(2);
 187
 188   return @result;
 189 }
 190
 191 sub selectfirst_hashref_query {
 192   $main::lxdebug->enter_sub(2);
 193
 194   my ($form, $dbh, $query) = splice(@_, 0, 3);
 195
 196   my $sth = prepare_execute_query($form, $dbh, $query, @_);
 197   my $ref = $sth->fetchrow_hashref();
 198   $sth->finish();
 199
 200   $main::lxdebug->leave_sub(2);
 201
 202   return $ref;
 203 }
 204
 205 sub selectfirst_array_query {
 206   $main::lxdebug->enter_sub(2);
 207
 208   my ($form, $dbh, $query) = splice(@_, 0, 3);
 209
 210   my $sth = prepare_execute_query($form, $dbh, $query, @_);
 211   my @ret = $sth->fetchrow_array();
 212   $sth->finish();
 213
 214   $main::lxdebug->leave_sub(2);
 215
 216   return @ret;
 217 }
 218
 219 sub selectall_as_map {
 220   $main::lxdebug->enter_sub(2);
 221
 222   my ($form, $dbh, $query, $key_col, $value_col) = splice(@_, 0, 5);
 223
 224   my $sth = prepare_execute_query($form, $dbh, $query, @_);
 225
 226   my %hash;
 227   if ('' eq ref $value_col) {
 228     while (my $ref = $sth->fetchrow_hashref()) {
 229       $hash{$ref->{$key_col} // ''} = $ref->{$value_col};
 230     }
 231   } else {
 232     while (my $ref = $sth->fetchrow_hashref()) {
 233       $hash{$ref->{$key_col} // ''} = { map { $_ => $ref->{$_} } @{ $value_col } };
 234     }
 235   }
 236
 237   $sth->finish();
 238
 239   $main::lxdebug->leave_sub(2);
 240
 241   return %hash;
 242 }
 243
 244 sub selectall_ids {
 245   $main::lxdebug->enter_sub(2);
 246
 247   my ($form, $dbh, $query, $key_col) = splice(@_, 0, 4);
 248
 249   my $sth = prepare_execute_query($form, $dbh, $query, @_);
 250
 251   my @ids;
 252   while (my $ref = $sth->fetchrow_arrayref()) {
 253     push @ids, $ref->[$key_col];
 254   }
 255
 256   $sth->finish;
 257
 258   $main::lxdebug->leave_sub(2);
 259
 260   return @ids;
 261 }
 262
 263 sub create_sort_spec {
 264   $main::lxdebug->enter_sub(2);
 265
 266   my %params = @_;
 267
 268   # Safety check:
 269   $params{defs}    || die;
 270   $params{default} || die;
 271
 272   # The definition of valid columns to sort by.
 273   my $defs        = $params{defs};
 274
 275   # The column name to sort by. Use the default column name if none was given.
 276   my %result      = ( 'column' => $params{column} || $params{default} );
 277
 278   # Overwrite the column name with the default column name if the other one is not valid.
 279   $result{column} = $params{default} unless ($defs->{ $result{column} });
 280
 281   # The sort direction. true means 'sort ascending', false means 'sort descending'.
 282   $result{dir}    = defined $params{dir}         ? $params{dir}
 283                   : defined $params{default_dir} ? $params{default_dir}
 284                   :                                1;
 285   $result{dir}    = $result{dir} ?     1 :      0;
 286   my $asc_desc    = $result{dir} ? 'ASC' : 'DESC';
 287
 288   # Create the SQL code.
 289   my $cols        = $defs->{ $result{column} };
 290   $result{sql}    = join ', ', map { "${_} ${asc_desc}" } @{ ref $cols eq 'ARRAY' ? $cols : [ $cols ] };
 291
 292   $main::lxdebug->leave_sub(2);
 293
 294   return %result;
 295 }
 296
 297 sub does_table_exist {
 298   $main::lxdebug->enter_sub(2);
 299
 300   my $dbh    = shift;
 301   my $table  = shift;
 302
 303   my $result = 0;
 304
 305   if ($dbh) {
 306     my $sth = $dbh->table_info('', '', $table, 'TABLE');
 307     if ($sth) {
 308       $result = $sth->fetchrow_hashref();
 309       $sth->finish();
 310     }
 311   }
 312
 313   $main::lxdebug->leave_sub(2);
 314
 315   return $result;
 316 }
 317
 318 # add token to values.
 319 # usage:
 320 #  add_token(
 321 #    \@where_tokens,
 322 #    \@where_values,
 323 #    col => 'id',
 324 #    val => [ 23, 34, 17 ]
 325 #    esc => \&conf_i
 326 #  )
 327 #  will append to the given arrays:
 328 #   -> 'id IN (?, ?, ?)'
 329 #   -> (conv_i(23), conv_i(34), conv_i(17))
 330 #
 331 #  features:
 332 #   - don't care if one or multiple values are given. singlewill result in 'col = ?'
 333 #   - pass escape routines
 334 #   - expand for future method
 335 #   - no need to type "push @where_tokens, 'id = ?'" over and over again
 336 sub add_token {
 337   my $tokens = shift() || [];
 338   my $values = shift() || [];
 339   my %params = @_;
 340   my $col    = $params{col};
 341   my $val    = $params{val};
 342   my $escape = $params{esc} || sub { $_ };
 343   my $method = $params{esc} =~ /^start|end|substr$/ ? 'ILIKE' : $params{method} || '=';
 344
 345   $val = [ $val ] unless ref $val eq 'ARRAY';
 346
 347   my %escapes = (
 348     id     => \&conv_i,
 349     bool   => \&conv_b,
 350     date   => \&conv_date,
 351     start  => sub { $_[0] . '%' },
 352     end    => sub { '%' . $_[0] },
 353     substr => sub { '%' . $_[0] . '%' },
 354   );
 355
 356   my $_long_token = sub {
 357     my $op = shift;
 358     sub {
 359       my $col = shift;
 360       return scalar @_ ? join ' OR ', ("$col $op ?") x scalar @_,
 361            :             undef;
 362     }
 363   };
 364
 365   my %methods = (
 366     '=' => sub {
 367       my $col = shift;
 368       return scalar @_ >  1 ? sprintf '%s IN (%s)', $col, join ', ', ("?") x scalar @_
 369            : scalar @_ == 1 ? sprintf '%s = ?',     $col
 370            :                  undef;
 371     },
 372     map({ $_ => $_long_token->($_) } qw(LIKE ILIKE >= <= > <)),
 373   );
 374
 375   $method = $methods{$method} || $method;
 376   $escape = $escapes{$escape} || $escape;
 377
 378   my $token = $method->($col, @{ $val });
 379   my @vals  = map { $escape->($_) } @{ $val };
 380
 381   return unless $token;
 382
 383   push @{ $tokens }, $token;
 384   push @{ $values }, @vals;
 385
 386   return ($token, @vals);
 387 }
 388
 389 1;
 390
 391
 392 __END__
 393
 394 =head1 NAME
 395
 396 SL::DBUTils.pm: All about database connections in kivitendo
 397
 398 =head1 SYNOPSIS
 399
 400   use DBUtils;
 401
 402   conv_i($str, $default)
 403   conv_date($str)
 404   conv_dateq($str)
 405   quote_db_date($date)
 406
 407   do_query($form, $dbh, $query)
 408   do_statement($form, $sth, $query)
 409
 410   dump_query($level, $msg, $query)
 411   prepare_execute_query($form, $dbh, $query)
 412
 413   my $all_results_ref       = selectall_hashref_query($form, $dbh, $query)
 414   my $first_result_hash_ref = selectfirst_hashref_query($form, $dbh, $query);
 415
 416   my @first_result =  selectfirst_array_query($form, $dbh, $query);  # ==
 417   my @first_result =  selectrow_query($form, $dbh, $query);
 418
 419   my %sort_spec = create_sort_spec(%params);
 420
 421 =head1 DESCRIPTION
 422
 423 DBUtils is the attempt to reduce the amount of overhead it takes to retrieve information from the database in kivitendo. Previously it would take about 15 lines of code just to get one single integer out of the database, including failure procedures and importing the necessary packages. Debugging would take even more.
 424
 425 Using DBUtils most database procedures can be reduced to defining the query, executing it, and retrieving the result. Let DBUtils handle the rest. Whenever there is a database operation not covered in DBUtils, add it here, rather than working around it in the backend code.
 426
 427 DBUtils relies heavily on two parameters which have to be passed to almost every function: $form and $dbh.
 428   - $form is used for error handling only. It can be omitted in theory, but should not.
 429   - $dbh is a handle to the database, as returned by the DBI::connect routine. If you don't have an active connection, you can query $form->get_standard_dbh() to get a generic no_auto connection. Don't forget to commit in this case!
 430
 431
 432 Every function here should accomplish the follwing things:
 433   - Easy debugging. Every handled query gets dumped via LXDebug, if specified there.
 434   - Safe value binding. Although DBI is far from perfect in terms of binding, the rest of the bindings should happen here.
 435   - Error handling. Should a query fail, an error message will be generated here instead of in the backend code invoking DBUtils.
 436
 437 Note that binding is not perfect here either...
 438
 439 =head2 QUOTING FUNCTIONS
 440
 441 =over 4
 442
 443 =item conv_i STR
 444
 445 =item conv_i STR,DEFAULT
 446
 447 Converts STR to an integer. If STR is empty, returns DEFAULT. If no DEFAULT is given, returns undef.
 448
 449 =item conv_date STR
 450
 451 Converts STR to a date string. If STR is emptry, returns undef.
 452
 453 =item conv_dateq STR
 454
 455 Database version of conv_date. Quotes STR before returning. Returns 'NULL' if STR is empty.
 456
 457 =item quote_db_date STR
 458
 459 Treats STR as a database date, quoting it. If STR equals current_date returns an escaped version which is treated as the current date by Postgres.
 460 Returns 'NULL' if STR is empty.
 461
 462 =back
 463
 464 =head2 QUERY FUNCTIONS
 465
 466 =over 4
 467
 468 =item do_query FORM,DBH,QUERY,ARRAY
 469
 470 Uses DBI::do to execute QUERY on DBH using ARRAY for binding values. FORM is only needed for error handling, but should always be passed nevertheless. Use this for insertions or updates that don't need to be prepared.
 471
 472 Returns the result of DBI::do which is -1 in case of an error and the number of affected rows otherwise.
 473
 474 =item do_statement FORM,STH,QUERY,ARRAY
 475
 476 Uses DBI::execute to execute QUERY on DBH using ARRAY for binding values. As with do_query, FORM is only used for error handling. If you are unsure what to use, refer to the documentation of DBI::do and DBI::execute.
 477
 478 Returns the result of DBI::execute which is -1 in case of an error and the number of affected rows otherwise.
 479
 480 =item prepare_execute_query FORM,DBH,QUERY,ARRAY
 481
 482 Prepares and executes QUERY on DBH using DBI::prepare and DBI::execute. ARRAY is passed as binding values to execute.
 483
 484 =back
 485
 486 =head2 RETRIEVAL FUNCTIONS
 487
 488 =over 4
 489
 490 =item selectfirst_array_query FORM,DBH,QUERY,ARRAY
 491
 492 =item selectrow_query FORM,DBH,QUERY,ARRAY
 493
 494 Prepares and executes a query using DBUtils functions, retireves the first row from the database, and returns it as an arrayref of the first row.
 495
 496 =item selectfirst_hashref_query FORM,DBH,QUERY,ARRAY
 497
 498 Prepares and executes a query using DBUtils functions, retireves the first row from the database, and returns it as a hashref of the first row.
 499
 500 =item selectall_hashref_query FORM,DBH,QUERY,ARRAY
 501
 502 Prepares and executes a query using DBUtils functions, retireves all data from the database, and returns it in hashref mode. This is slightly confusing, as the data structure will actually be a reference to an array, containing hashrefs for each row.
 503
 504 =item selectall_as_map FORM,DBH,QUERY,KEY_COL,VALUE_COL,ARRAY
 505
 506 Prepares and executes a query using DBUtils functions, retireves all data from the database, and creates a hash from the results using KEY_COL as the column for the hash keys and VALUE_COL for its values.
 507
 508 =back
 509
 510 =head2 UTILITY FUNCTIONS
 511
 512 =over 4
 513
 514 =item create_sort_spec
 515
 516   params:
 517     defs        => { },         # mandatory
 518     default     => 'name',      # mandatory
 519     column      => 'name',
 520     default_dir => 0|1,
 521     dir         => 0|1,
 522
 523   returns hash:
 524     column      => 'name',
 525     dir         => 0|1,
 526     sql         => 'SQL code',
 527
 528 This function simplifies the creation of SQL code for sorting
 529 columns. It uses a hashref of valid column names, the column name and
 530 direction requested by the user, the application defaults for the
 531 column name and the direction and returns the actual column name,
 532 direction and SQL code that can be used directly in a query.
 533
 534 The parameter 'defs' is a hash reference. The keys are the column
 535 names as they may come from the application. The values are either
 536 scalars with SQL code or array references of SQL code. Example:
 537
 538 'defs' => { 'customername' => 'lower(customer.name)',
 539             'address'      => [ 'lower(customer.city)', 'lower(customer.street)' ], }
 540
 541 'default' is the default column name to sort by. It must be a key of
 542 'defs' and should not be come from user input.
 543
 544 The 'column' parameter is the column name as requested by the
 545 application (e.g. if the user clicked on a column header in a
 546 report). If it is invalid then the 'default' parameter will be used
 547 instead.
 548
 549 'default_dir' is the default sort direction. A true value means 'sort
 550 ascending', a false one 'sort descending'. 'default_dir' defaults to
 551 '1' if undefined.
 552
 553 The 'dir' parameter is the sort direction as requested by the
 554 application (e.g. if the user clicked on a column header in a
 555 report). If it is undefined then the 'default_dir' parameter will be
 556 used instead.
 557
 558 =back
 559
 560 =head2 DEBUG FUNCTIONS
 561
 562 =over 4
 563
 564 =item dump_query LEVEL,MSG,QUERY,ARRAY
 565
 566 Dumps a query using LXDebug->message, using LEVEL for the debug-level of LXDebug. If MSG is given, it preceeds the QUERY dump in the logfiles. ARRAY is used to interpolate the '?' placeholders in QUERY, the resulting QUERY can be copy-pasted into a database frontend for debugging. Note that this method is also automatically called by each of the other QUERY FUNCTIONS, so there is in general little need to invoke it manually.
 567
 568 =back
 569
 570 =head1 EXAMPLES
 571
 572 =over 4
 573
 574 =item Retrieving a whole table:
 575
 576   $query = qq|SELECT id, pricegroup FROM pricegroup|;
 577   $form->{PRICEGROUPS} = selectall_hashref_query($form, $dbh, $query);
 578
 579 =item Retrieving a single value:
 580
 581   $query = qq|SELECT nextval('glid')|;
 582   ($new_id) = selectrow_query($form, $dbh, $query);
 583
 584 =item Using binding values:
 585
 586   $query = qq|UPDATE ar SET paid = amount + paid, storno = 't' WHERE id = ?|;
 587   do_query($form, $dbh, $query, $id);
 588
 589 =item A more complicated example, using dynamic binding values:
 590
 591   my @values;
 592
 593   if ($form->{language_values} ne "") {
 594     $query = qq|SELECT l.id, l.description, tr.translation, tr.longdescription
 595                   FROM language l
 596                   LEFT OUTER JOIN translation tr ON (tr.language_id = l.id) AND (tr.parts_id = ?)|;
 597     @values = (conv_i($form->{id}));
 598   } else {
 599     $query = qq|SELECT id, description FROM language|;
 600   }
 601
 602   my $languages = selectall_hashref_query($form, $dbh, $query, @values);
 603
 604 =back
 605
 606 =head1 MODULE AUTHORS
 607
 608 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 609 Sven Schoeling E<lt>s.schoeling@linet-services.deE<gt>
 610
 611 =head1 DOCUMENTATION AUTHORS
 612
 613 Udo Spallek E<lt>udono@gmx.netE<gt>
 614 Sven Schoeling E<lt>s.schoeling@linet-services.deE<gt>
 615
 616 =head1 COPYRIGHT AND LICENSE
 617
 618 Copyright 2007 by kivitendo Community
 619
 620 This program is free software; you can redistribute it and/or modify
 621 it under the terms of the GNU General Public License as published by
 622 the Free Software Foundation; either version 2 of the License, or
 623 (at your option) any later version.
 624
 625 This program is distributed in the hope that it will be useful,
 626 but WITHOUT ANY WARRANTY; without even the implied warranty of
 627 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 628 GNU General Public License for more details.
 629 You should have received a copy of the GNU General Public License
 630 along with this program; if not, write to the Free Software
 631 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 632
 633 =cut