SL/DBUtils.pm

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