6 our @ISA = qw(Exporter);
8 our @EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement
9 dump_query quote_db_date like
10 selectfirst_hashref_query selectfirst_array_query
11 selectall_hashref_query selectall_array_query
14 prepare_execute_query prepare_query
15 create_sort_spec does_table_exist
21 my ($value, $default) = @_;
22 return (defined($value) && "$value" ne "") ? $value * 1 : $default;
27 my ($value, $default) = @_;
28 return !defined $value && defined $default ? $default
35 return undef if !defined $value;
36 $value = trim($value);
37 return $value eq "" ? undef : $value;
42 if (defined($value) && "$value" ne "") {
43 $value =~ s/\'/\'\'/g;
50 $main::lxdebug->enter_sub(2);
52 my ($form, $dbh, $query) = splice(@_, 0, 3);
54 dump_query(LXDebug->QUERY(), '', $query, @_);
57 if (0 == scalar(@_)) {
58 $result = $dbh->do($query) || $form->dberror($query);
60 $result = $dbh->do($query, undef, @_) || $form->dberror($query . " (" . join(", ", @_) . ")");
63 $main::lxdebug->leave_sub(2);
68 sub selectrow_query { &selectfirst_array_query }
71 $main::lxdebug->enter_sub(2);
73 my ($form, $sth, $query) = splice(@_, 0, 3);
75 dump_query(LXDebug->QUERY(), '', $query, @_);
78 if (0 == scalar(@_)) {
79 $result = $sth->execute() || $form->dberror($query);
81 $result = $sth->execute(@_) || $form->dberror($query . " (" . join(", ", @_) . ")");
84 $main::lxdebug->leave_sub(2);
90 my ($level, $msg, $query) = splice(@_, 0, 3);
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++;
99 while ($query =~ /\?/) {
100 my $value = shift || '';
101 $value =~ s/\'/\\\'/g;
102 $value = "'${value}'";
103 $query =~ s/\?/$value/;
106 $query =~ s/[\n\s]+/ /g;
108 $msg .= " " if ($msg);
110 my $info = "$subroutine called from $filename:$line\n";
112 $main::lxdebug->message($level, $info . $msg . $query);
118 return "NULL" unless defined $str;
119 return "current_date" if $str =~ /current_date/;
126 $main::lxdebug->enter_sub(2);
128 my ($form, $dbh, $query) = splice(@_, 0, 3);
130 dump_query(LXDebug->QUERY(), '', $query, @_);
132 my $sth = $dbh->prepare($query) || $form->dberror($query);
134 $main::lxdebug->leave_sub(2);
139 sub prepare_execute_query {
140 $main::lxdebug->enter_sub(2);
142 my ($form, $dbh, $query) = splice(@_, 0, 3);
144 dump_query(LXDebug->QUERY(), '', $query, @_);
146 my $sth = $dbh->prepare($query) || $form->dberror($query);
147 if (scalar(@_) != 0) {
148 $sth->execute(@_) || $form->dberror($query . " (" . join(", ", @_) . ")");
150 $sth->execute() || $form->dberror($query);
153 $main::lxdebug->leave_sub(2);
158 sub selectall_hashref_query {
159 $main::lxdebug->enter_sub(2);
161 my ($form, $dbh, $query) = splice(@_, 0, 3);
163 dump_query(LXDebug->QUERY(), '', $query, @_);
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(", ", @_) . ")" : ''));
169 $main::lxdebug->leave_sub(2);
171 return wantarray ? @{ $result } : $result;
174 sub selectall_array_query {
175 $main::lxdebug->enter_sub(2);
177 my ($form, $dbh, $query) = splice(@_, 0, 3);
179 my $sth = prepare_execute_query($form, $dbh, $query, @_);
181 while (my ($value) = $sth->fetchrow_array()) {
182 push(@result, $value);
186 $main::lxdebug->leave_sub(2);
191 sub selectfirst_hashref_query {
192 $main::lxdebug->enter_sub(2);
194 my ($form, $dbh, $query) = splice(@_, 0, 3);
196 my $sth = prepare_execute_query($form, $dbh, $query, @_);
197 my $ref = $sth->fetchrow_hashref();
200 $main::lxdebug->leave_sub(2);
205 sub selectfirst_array_query {
206 $main::lxdebug->enter_sub(2);
208 my ($form, $dbh, $query) = splice(@_, 0, 3);
210 my $sth = prepare_execute_query($form, $dbh, $query, @_);
211 my @ret = $sth->fetchrow_array();
214 $main::lxdebug->leave_sub(2);
219 sub selectall_as_map {
220 $main::lxdebug->enter_sub(2);
222 my ($form, $dbh, $query, $key_col, $value_col) = splice(@_, 0, 5);
224 my $sth = prepare_execute_query($form, $dbh, $query, @_);
227 if ('' eq ref $value_col) {
228 while (my $ref = $sth->fetchrow_hashref()) {
229 $hash{$ref->{$key_col} // ''} = $ref->{$value_col};
232 while (my $ref = $sth->fetchrow_hashref()) {
233 $hash{$ref->{$key_col} // ''} = { map { $_ => $ref->{$_} } @{ $value_col } };
239 $main::lxdebug->leave_sub(2);
245 $main::lxdebug->enter_sub(2);
247 my ($form, $dbh, $query, $key_col) = splice(@_, 0, 4);
249 my $sth = prepare_execute_query($form, $dbh, $query, @_);
252 while (my $ref = $sth->fetchrow_arrayref()) {
253 push @ids, $ref->[$key_col];
258 $main::lxdebug->leave_sub(2);
263 sub create_sort_spec {
264 $main::lxdebug->enter_sub(2);
269 $params{defs} || die;
270 $params{default} || die;
272 # The definition of valid columns to sort by.
273 my $defs = $params{defs};
275 # The column name to sort by. Use the default column name if none was given.
276 my %result = ( 'column' => $params{column} || $params{default} );
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} });
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}
285 $result{dir} = $result{dir} ? 1 : 0;
286 my $asc_desc = $result{dir} ? 'ASC' : 'DESC';
288 # Create the SQL code.
289 my $cols = $defs->{ $result{column} };
290 $result{sql} = join ', ', map { "${_} ${asc_desc}" } @{ ref $cols eq 'ARRAY' ? $cols : [ $cols ] };
292 $main::lxdebug->leave_sub(2);
297 sub does_table_exist {
298 $main::lxdebug->enter_sub(2);
306 my $sth = $dbh->table_info('', '', $table, 'TABLE');
308 $result = $sth->fetchrow_hashref();
313 $main::lxdebug->leave_sub(2);
318 # add token to values.
324 # val => [ 23, 34, 17 ]
327 # will append to the given arrays:
328 # -> 'id IN (?, ?, ?)'
329 # -> (conv_i(23), conv_i(34), conv_i(17))
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
337 my $tokens = shift() || [];
338 my $values = shift() || [];
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} || '=';
345 $val = [ $val ] unless ref $val eq 'ARRAY';
351 start => sub { trim($_[0]) . '%' },
352 end => sub { '%' . trim($_[0]) },
353 substr => sub { like($_[0]) },
356 my $_long_token = sub {
360 return scalar @_ ? join ' OR ', ("$col $op ?") x scalar @_,
368 return scalar @_ > 1 ? sprintf '%s IN (%s)', $col, join ', ', ("?") x scalar @_
369 : scalar @_ == 1 ? sprintf '%s = ?', $col
372 map({ $_ => $_long_token->($_) } qw(LIKE ILIKE >= <= > <)),
375 $method = $methods{$method} || $method;
376 $escape = $escapes{$escape} || $escape;
378 my $token = $method->($col, @{ $val });
379 my @vals = map { $escape->($_) } @{ $val };
381 return unless $token;
383 push @{ $tokens }, $token;
384 push @{ $values }, @vals;
386 return ($token, @vals);
392 return "%" . SL::Util::trim($string // '') . "%";
395 sub role_is_superuser {
396 my ($dbh, $login) = @_;
397 my ($is_superuser) = $dbh->selectrow_array(qq|SELECT usesuper FROM pg_user WHERE usename = ?|, undef, $login);
399 return $is_superuser;
411 SL::DBUTils.pm: All about database connections in kivitendo
417 conv_i($str, $default)
422 do_query($form, $dbh, $query)
423 do_statement($form, $sth, $query)
425 dump_query($level, $msg, $query)
426 prepare_execute_query($form, $dbh, $query)
428 my $all_results_ref = selectall_hashref_query($form, $dbh, $query)
429 my $first_result_hash_ref = selectfirst_hashref_query($form, $dbh, $query);
431 my @first_result = selectfirst_array_query($form, $dbh, $query); # ==
432 my @first_result = selectrow_query($form, $dbh, $query);
434 my %sort_spec = create_sort_spec(%params);
438 DBUtils provides wrapper functions for low level database retrieval. It saves
439 you the trouble of mucking around with statement handles for small database
440 queries and does exception handling in the common cases for you.
442 Query and retrieval functions share the parameter scheme:
444 query_or_retrieval(C<FORM, DBH, QUERY[, BINDVALUES]>)
450 C<FORM> is used for error handling only. It can be omitted in theory, but should
451 not. In most cases you will call it with C<$::form>.
455 C<DBH> is a handle to the database, as returned by the C<DBI::connect> routine.
456 If you don't have an active connection, you can use
457 C<<$::form->get_standard_dbh>> to get a generic no_auto connection or get a
458 C<Rose::DB::Object> handle from any RDBO class with
459 C<<SL::DB::Part->new->db->dbh>>. The former will be without autocommit, the
460 latter with autocommit.
462 See C<PITFALLS AND CAVEATS> for common errors.
466 C<QUERY> must be exactly one query. You don't need to include the terminal
467 C<;>. There must be no tainted data interpolated into the string. Instead use
468 the DBI placeholder syntax.
472 All additional parameters will be used as C<BINDVALUES> for the query. Note
473 that DBI can't bind arrays to a C<id IN (?)>, so you will need to generate a
474 statement with exactly one C<?> for each bind value. DBI can however bind
475 DateTime objects, and you should always pass these for date selections.
479 =head1 PITFALLS AND CAVEATS
483 As mentioned above, there are two sources of database handles in the program:
484 C<<$::form->get_standard_dbh>> and C<<SL::DB::Object->new->db->dbh>>. It's easy
485 to produce deadlocks when using both of them. To reduce the likelyhood of
486 locks, try to obey these rules:
492 In a controller that uses Rose objects, never use C<get_standard_dbh>.
496 In backend code, that has no preference, always accept the database handle as a
497 parameter from the controller.
503 C<DBUtils> is one of the last modules in the program to use C<@EXPORT> instead
504 of C<@EXPORT_OK>. This means it will flood your namespace with its functions,
505 causing potential clashes. When writing new code, always either export nothing
509 DBUtils::selectall_hashref_query(...)
511 or export only what you need:
513 use SL::DBUtils qw(selectall_hashref_query);
514 selectall_hashref_query(...)
519 Since it is really easy to write something like
521 my $all_parts = selectall_hashref_query($::form, $dbh, 'SELECT * FROM parts');
523 people do so from time to time. When writing code, consider this a ticking
524 timebomb. Someone out there has a database with 1mio parts in it, and this
525 statement just shovelled ate 2GB of memory and timeouted the request.
527 Parts may be the obvious example, but the same applies to customer, vendors,
528 records, projects or custom variables.
531 =head1 QUOTING FUNCTIONS
537 =item conv_i STR,DEFAULT
539 Converts STR to an integer. If STR is empty, returns DEFAULT. If no DEFAULT is
540 given, returns undef.
544 Converts STR to a date string. If STR is emptry, returns undef.
548 Database version of conv_date. Quotes STR before returning. Returns 'NULL' if
551 =item quote_db_date STR
553 Treats STR as a database date, quoting it. If STR equals current_date returns
554 an escaped version which is treated as the current date by Postgres.
556 Returns C<'NULL'> if STR is empty.
560 Turns C<STR> into an argument suitable for SQL's C<LIKE> and C<ILIKE>
561 operators by Trimming the string C<STR> (removes leading and trailing
562 whitespaces) and prepending and appending C<%>.
566 =head1 QUERY FUNCTIONS
570 =item do_query FORM,DBH,QUERY,ARRAY
572 Uses DBI::do to execute QUERY on DBH using ARRAY for binding values. FORM is
573 only needed for error handling, but should always be passed nevertheless. Use
574 this for insertions or updates that don't need to be prepared.
576 Returns the result of DBI::do which is -1 in case of an error and the number of
577 affected rows otherwise.
579 =item do_statement FORM,STH,QUERY,ARRAY
581 Uses DBI::execute to execute QUERY on DBH using ARRAY for binding values. As
582 with do_query, FORM is only used for error handling. If you are unsure what to
583 use, refer to the documentation of DBI::do and DBI::execute.
585 Returns the result of DBI::execute which is -1 in case of an error and the
586 number of affected rows otherwise.
588 =item prepare_execute_query FORM,DBH,QUERY,ARRAY
590 Prepares and executes QUERY on DBH using DBI::prepare and DBI::execute. ARRAY
591 is passed as binding values to execute.
595 =head1 RETRIEVAL FUNCTIONS
599 =item selectfirst_array_query FORM,DBH,QUERY,ARRAY
601 =item selectrow_query FORM,DBH,QUERY,ARRAY
603 Prepares and executes a query using DBUtils functions, retrieves the first row
604 from the database, and returns it as an arrayref of the first row.
606 =item selectfirst_hashref_query FORM,DBH,QUERY,ARRAY
608 Prepares and executes a query using DBUtils functions, retrieves the first row
609 from the database, and returns it as a hashref of the first row.
611 =item selectall_hashref_query FORM,DBH,QUERY,ARRAY
613 Prepares and executes a query using DBUtils functions, retrieves all data from
614 the database, and returns it in hashref mode. This is slightly confusing, as
615 the data structure will actually be a reference to an array, containing
616 hashrefs for each row.
618 =item selectall_as_map FORM,DBH,QUERY,KEY_COL,VALUE_COL,ARRAY
620 Prepares and executes a query using DBUtils functions, retrieves all data from
621 the database, and creates a hash from the results using KEY_COL as the column
622 for the hash keys and VALUE_COL for its values.
626 =head1 UTILITY FUNCTIONS
630 =item create_sort_spec
633 defs => { }, # mandatory
634 default => 'name', # mandatory
644 This function simplifies the creation of SQL code for sorting
645 columns. It uses a hashref of valid column names, the column name and
646 direction requested by the user, the application defaults for the
647 column name and the direction and returns the actual column name,
648 direction and SQL code that can be used directly in a query.
650 The parameter 'defs' is a hash reference. The keys are the column
651 names as they may come from the application. The values are either
652 scalars with SQL code or array references of SQL code. Example:
655 customername => 'lower(customer.name)',
656 address => [ 'lower(customer.city)', 'lower(customer.street)' ],
659 'default' is the default column name to sort by. It must be a key of
660 'defs' and should not be come from user input.
662 The 'column' parameter is the column name as requested by the
663 application (e.g. if the user clicked on a column header in a
664 report). If it is invalid then the 'default' parameter will be used
667 'default_dir' is the default sort direction. A true value means 'sort
668 ascending', a false one 'sort descending'. 'default_dir' defaults to
671 The 'dir' parameter is the sort direction as requested by the
672 application (e.g. if the user clicked on a column header in a
673 report). If it is undefined then the 'default_dir' parameter will be
678 =head1 DEBUG FUNCTIONS
682 =item dump_query LEVEL,MSG,QUERY,ARRAY
684 Dumps a query using LXDebug->message, using LEVEL for the debug-level of
685 LXDebug. If MSG is given, it preceeds the QUERY dump in the logfiles. ARRAY is
686 used to interpolate the '?' placeholders in QUERY, the resulting QUERY can be
687 copy-pasted into a database frontend for debugging. Note that this method is
688 also automatically called by each of the other QUERY FUNCTIONS, so there is in
689 general little need to invoke it manually.
697 =item Retrieving a whole table:
699 $query = qq|SELECT id, pricegroup FROM pricegroup|;
700 $form->{PRICEGROUPS} = selectall_hashref_query($form, $dbh, $query);
702 =item Retrieving a single value:
704 $query = qq|SELECT nextval('glid')|;
705 ($new_id) = selectrow_query($form, $dbh, $query);
707 =item Using binding values:
709 $query = qq|UPDATE ar SET paid = amount + paid, storno = 't' WHERE id = ?|;
710 do_query($form, $dbh, $query, $id);
712 =item A more complicated example, using dynamic binding values:
716 if ($form->{language_values} ne "") {
718 SELECT l.id, l.description, tr.translation, tr.longdescription
720 LEFT JOIN translation tr ON (tr.language_id = l.id AND tr.parts_id = ?)
722 @values = (conv_i($form->{id}));
724 $query = qq|SELECT id, description FROM language|;
727 my $languages = selectall_hashref_query($form, $dbh, $query, @values);
731 =head1 MODULE AUTHORS
733 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
734 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
736 =head1 DOCUMENTATION AUTHORS
738 Udo Spallek E<lt>udono@gmx.netE<gt>
739 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
741 =head1 COPYRIGHT AND LICENSE
743 Copyright 2007 by kivitendo Community
745 This program is free software; you can redistribute it and/or modify
746 it under the terms of the GNU General Public License as published by
747 the Free Software Foundation; either version 2 of the License, or
748 (at your option) any later version.
750 This program is distributed in the hope that it will be useful,
751 but WITHOUT ANY WARRANTY; without even the implied warranty of
752 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
753 GNU General Public License for more details.
754 You should have received a copy of the GNU General Public License
755 along with this program; if not, write to the Free Software
756 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.