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