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