Doku: Zuviele TeX-Pakete angegeben
[kivitendo-erp.git] / 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 like
10              selectfirst_hashref_query selectfirst_array_query
11              selectall_hashref_query selectall_array_query selectcol_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 =~ m{$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 { goto &selectcol_array_query; }
175
176 sub selectcol_array_query {
177   $main::lxdebug->enter_sub(2);
178
179   my ($form, $dbh, $query) = splice(@_, 0, 3);
180
181   my $sth = prepare_execute_query($form, $dbh, $query, @_);
182   my @result = @{ $dbh->selectcol_arrayref($sth) };
183   $sth->finish();
184
185   $main::lxdebug->leave_sub(2);
186
187   return @result;
188 }
189
190 sub selectfirst_hashref_query {
191   $main::lxdebug->enter_sub(2);
192
193   my ($form, $dbh, $query) = splice(@_, 0, 3);
194
195   my $sth = prepare_execute_query($form, $dbh, $query, @_);
196   my $ref = $sth->fetchrow_hashref();
197   $sth->finish();
198
199   $main::lxdebug->leave_sub(2);
200
201   return $ref;
202 }
203
204 sub selectfirst_array_query {
205   $main::lxdebug->enter_sub(2);
206
207   my ($form, $dbh, $query) = splice(@_, 0, 3);
208
209   my $sth = prepare_execute_query($form, $dbh, $query, @_);
210   my @ret = $sth->fetchrow_array();
211   $sth->finish();
212
213   $main::lxdebug->leave_sub(2);
214
215   return @ret;
216 }
217
218 sub selectall_as_map {
219   $main::lxdebug->enter_sub(2);
220
221   my ($form, $dbh, $query, $key_col, $value_col) = splice(@_, 0, 5);
222
223   my $sth = prepare_execute_query($form, $dbh, $query, @_);
224
225   my %hash;
226   if ('' eq ref $value_col) {
227     while (my $ref = $sth->fetchrow_hashref()) {
228       $hash{$ref->{$key_col} // ''} = $ref->{$value_col};
229     }
230   } else {
231     while (my $ref = $sth->fetchrow_hashref()) {
232       $hash{$ref->{$key_col} // ''} = { map { $_ => $ref->{$_} } @{ $value_col } };
233     }
234   }
235
236   $sth->finish();
237
238   $main::lxdebug->leave_sub(2);
239
240   return %hash;
241 }
242
243 sub selectall_ids {
244   $main::lxdebug->enter_sub(2);
245
246   my ($form, $dbh, $query, $key_col) = splice(@_, 0, 4);
247
248   my $sth = prepare_execute_query($form, $dbh, $query, @_);
249
250   my @ids;
251   while (my $ref = $sth->fetchrow_arrayref()) {
252     push @ids, $ref->[$key_col];
253   }
254
255   $sth->finish;
256
257   $main::lxdebug->leave_sub(2);
258
259   return @ids;
260 }
261
262 sub create_sort_spec {
263   $main::lxdebug->enter_sub(2);
264
265   my %params = @_;
266
267   # Safety check:
268   $params{defs}    || die;
269   $params{default} || die;
270
271   # The definition of valid columns to sort by.
272   my $defs        = $params{defs};
273
274   # The column name to sort by. Use the default column name if none was given.
275   my %result      = ( 'column' => $params{column} || $params{default} );
276
277   # Overwrite the column name with the default column name if the other one is not valid.
278   $result{column} = $params{default} unless ($defs->{ $result{column} });
279
280   # The sort direction. true means 'sort ascending', false means 'sort descending'.
281   $result{dir}    = defined $params{dir}         ? $params{dir}
282                   : defined $params{default_dir} ? $params{default_dir}
283                   :                                1;
284   $result{dir}    = $result{dir} ?     1 :      0;
285   my $asc_desc    = $result{dir} ? 'ASC' : 'DESC';
286
287   # Create the SQL code.
288   my $cols        = $defs->{ $result{column} };
289   $result{sql}    = join ', ', map { "${_} ${asc_desc}" } @{ ref $cols eq 'ARRAY' ? $cols : [ $cols ] };
290
291   $main::lxdebug->leave_sub(2);
292
293   return %result;
294 }
295
296 sub does_table_exist {
297   $main::lxdebug->enter_sub(2);
298
299   my $dbh    = shift;
300   my $table  = shift;
301
302   my $result = 0;
303
304   if ($dbh) {
305     my $sth = $dbh->table_info('', '', $table, 'TABLE');
306     if ($sth) {
307       $result = $sth->fetchrow_hashref();
308       $sth->finish();
309     }
310   }
311
312   $main::lxdebug->leave_sub(2);
313
314   return $result;
315 }
316
317 # add token to values.
318 # usage:
319 #  add_token(
320 #    \@where_tokens,
321 #    \@where_values,
322 #    col => 'id',
323 #    val => [ 23, 34, 17 ]
324 #    esc => \&conf_i
325 #  )
326 #  will append to the given arrays:
327 #   -> 'id IN (?, ?, ?)'
328 #   -> (conv_i(23), conv_i(34), conv_i(17))
329 #
330 #  features:
331 #   - don't care if one or multiple values are given. singlewill result in 'col = ?'
332 #   - pass escape routines
333 #   - expand for future method
334 #   - no need to type "push @where_tokens, 'id = ?'" over and over again
335 sub add_token {
336   my $tokens = shift() || [];
337   my $values = shift() || [];
338   my %params = @_;
339   my $col    = $params{col};
340   my $val    = $params{val};
341   my $escape = $params{esc} || sub { $_ };
342   my $method = $params{esc} =~ /^start|end|substr$/ ? 'ILIKE' : $params{method} || '=';
343
344   $val = [ $val ] unless ref $val eq 'ARRAY';
345
346   my %escapes = (
347     id     => \&conv_i,
348     bool   => \&conv_b,
349     date   => \&conv_date,
350     start  => sub { trim($_[0]) . '%' },
351     end    => sub { '%' . trim($_[0]) },
352     substr => sub { like($_[0]) },
353   );
354
355   my $_long_token = sub {
356     my $op = shift;
357     sub {
358       my $col = shift;
359       return scalar @_ ? join ' OR ', ("$col $op ?") x scalar @_,
360            :             undef;
361     }
362   };
363
364   my %methods = (
365     '=' => sub {
366       my $col = shift;
367       return scalar @_ >  1 ? sprintf '%s IN (%s)', $col, join ', ', ("?") x scalar @_
368            : scalar @_ == 1 ? sprintf '%s = ?',     $col
369            :                  undef;
370     },
371     map({ $_ => $_long_token->($_) } qw(LIKE ILIKE >= <= > <)),
372   );
373
374   $method = $methods{$method} || $method;
375   $escape = $escapes{$escape} || $escape;
376
377   my $token = $method->($col, @{ $val });
378   my @vals  = map { $escape->($_) } @{ $val };
379
380   return unless $token;
381
382   push @{ $tokens }, $token;
383   push @{ $values }, @vals;
384
385   return ($token, @vals);
386 }
387
388 sub like {
389   my ($string) = @_;
390
391   return "%" . SL::Util::trim($string // '') . "%";
392 }
393
394 sub role_is_superuser {
395   my ($dbh, $login)  = @_;
396   my ($is_superuser) = $dbh->selectrow_array(qq|SELECT usesuper FROM pg_user WHERE usename = ?|, undef, $login);
397
398   return $is_superuser;
399 }
400
401 1;
402
403
404 __END__
405
406 =encoding utf-8
407
408 =head1 NAME
409
410 SL::DBUtils.pm: All about database connections in kivitendo
411
412 =head1 SYNOPSIS
413
414   use DBUtils;
415
416   conv_i($str, $default)
417   conv_date($str)
418   conv_dateq($str)
419   quote_db_date($date)
420
421   my $dbh = SL::DB->client->dbh;
422
423   do_query($form, $dbh, $query)
424   do_statement($form, $sth, $query)
425
426   dump_query($level, $msg, $query)
427   prepare_execute_query($form, $dbh, $query)
428
429   my $all_results_ref       = selectall_hashref_query($form, $dbh, $query)
430   my $first_result_hash_ref = selectfirst_hashref_query($form, $dbh, $query);
431
432   my @first_result =  selectfirst_array_query($form, $dbh, $query);
433   my @first_result =  selectrow_query($form, $dbh, $query);
434
435   my @values = selectcol_array_query($form, $dbh, $query);
436
437   my %sort_spec = create_sort_spec(%params);
438
439 =head1 DESCRIPTION
440
441 DBUtils provides wrapper functions for low level database retrieval. It saves
442 you the trouble of mucking around with statement handles for small database
443 queries and does exception handling in the common cases for you.
444
445 Query and retrieval functions share the parameter scheme:
446
447   query_or_retrieval(C<FORM, DBH, QUERY[, BINDVALUES]>)
448
449 =over 4
450
451 =item *
452
453 C<FORM> is used for error handling only. It can be omitted in theory, but should
454 not. In most cases you will call it with C<$::form>.
455
456 =item *
457
458 C<DBH> is a handle to the database, as returned by the C<DBI::connect> routine.
459 If you don't have an active connection, you can use
460 C<SL::DB->client->dbh> or get a C<Rose::DB::Object> handle from any RDBO class with
461 C<<SL::DB::Part->new->db->dbh>>. In both cases the handle will have AutoCommit set.
462
463 See C<PITFALLS AND CAVEATS> for common errors.
464
465 =item *
466
467 C<QUERY> must be exactly one query. You don't need to include the terminal
468 C<;>. There must be no tainted data interpolated into the string. Instead use
469 the DBI placeholder syntax.
470
471 =item *
472
473 All additional parameters will be used as C<BINDVALUES> for the query. Note
474 that DBI can't bind arrays to a C<id IN (?)>, so you will need to generate a
475 statement with exactly one C<?> for each bind value. DBI can however bind
476 DateTime objects, and you should always pass these for date selections.
477
478 =back
479
480 =head1 PITFALLS AND CAVEATS
481
482 =head2 Locking
483
484 As mentioned above, there are two sources of database handles in the program:
485 C<<$::form->get_standard_dbh>> and C<<SL::DB::Object->new->db->dbh>>. It's easy
486 to produce deadlocks when using both of them. To reduce the likelyhood of
487 locks, try to obey these rules:
488
489 =over 4
490
491 =item *
492
493 In a controller that uses Rose objects, never use C<get_standard_dbh>.
494
495 =item *
496
497 In backend code, that has no preference, always accept the database handle as a
498 parameter from the controller.
499
500 =back
501
502 =head2 Exports
503
504 C<DBUtils> is one of the last modules in the program to use C<@EXPORT> instead
505 of C<@EXPORT_OK>. This means it will flood your namespace with its functions,
506 causing potential clashes. When writing new code, always either export nothing
507 and call directly:
508
509   use SL::DBUtils ();
510   DBUtils::selectall_hashref_query(...)
511
512 or export only what you need:
513
514   use SL::DBUtils qw(selectall_hashref_query);
515   selectall_hashref_query(...)
516
517
518 =head2 Performance
519
520 Since it is really easy to write something like
521
522   my $all_parts = selectall_hashref_query($::form, $dbh, 'SELECT * FROM parts');
523
524 people do so from time to time. When writing code, consider this a ticking
525 timebomb. Someone out there has a database with 1mio parts in it, and this
526 statement just gobbled up 2GB of memory and timeouted the request.
527
528 Parts may be the obvious example, but the same applies to customer, vendors,
529 records, projects or custom variables.
530
531
532 =head1 QUOTING FUNCTIONS
533
534 =over 4
535
536 =item conv_i STR
537
538 =item conv_i STR,DEFAULT
539
540 Converts STR to an integer. If STR is empty, returns DEFAULT. If no DEFAULT is
541 given, returns undef.
542
543 =item conv_date STR
544
545 Converts STR to a date string. If STR is emptry, returns undef.
546
547 =item conv_dateq STR
548
549 Database version of conv_date. Quotes STR before returning. Returns 'NULL' if
550 STR is empty.
551
552 =item quote_db_date STR
553
554 Treats STR as a database date, quoting it. If STR equals current_date returns
555 an escaped version which is treated as the current date by Postgres.
556
557 Returns C<'NULL'> if STR is empty.
558
559 =item like STR
560
561 Turns C<STR> into an argument suitable for SQL's C<LIKE> and C<ILIKE>
562 operators by Trimming the string C<STR> (removes leading and trailing
563 whitespaces) and prepending and appending C<%>.
564
565 =back
566
567 =head1 QUERY FUNCTIONS
568
569 =over 4
570
571 =item do_query FORM,DBH,QUERY,ARRAY
572
573 Uses DBI::do to execute QUERY on DBH using ARRAY for binding values. FORM is
574 only needed for error handling, but should always be passed nevertheless. Use
575 this for insertions or updates that don't need to be prepared.
576
577 Returns the result of DBI::do which is -1 in case of an error and the number of
578 affected rows otherwise.
579
580 =item do_statement FORM,STH,QUERY,ARRAY
581
582 Uses DBI::execute to execute QUERY on DBH using ARRAY for binding values. As
583 with do_query, FORM is only used for error handling. If you are unsure what to
584 use, refer to the documentation of DBI::do and DBI::execute.
585
586 Returns the result of DBI::execute which is -1 in case of an error and the
587 number of affected rows otherwise.
588
589 =item prepare_execute_query FORM,DBH,QUERY,ARRAY
590
591 Prepares and executes QUERY on DBH using DBI::prepare and DBI::execute. ARRAY
592 is passed as binding values to execute.
593
594 =back
595
596 =head1 RETRIEVAL FUNCTIONS
597
598 =over 4
599
600 =item selectfirst_array_query FORM,DBH,QUERY,ARRAY
601
602 =item selectrow_query FORM,DBH,QUERY,ARRAY
603
604 Prepares and executes a query using DBUtils functions, retrieves the first row
605 from the database, and returns it as an arrayref of the first row.
606
607 =item selectfirst_hashref_query FORM,DBH,QUERY,ARRAY
608
609 Prepares and executes a query using DBUtils functions, retrieves the first row
610 from the database, and returns it as a hashref of the first row.
611
612 =item selectall_hashref_query FORM,DBH,QUERY,ARRAY
613
614 Prepares and executes a query using DBUtils functions, retrieves all data from
615 the database, and returns it in hashref mode. This is slightly confusing, as
616 the data structure will actually be a reference to an array, containing
617 hashrefs for each row.
618
619
620 =item selectall_array_query FORM,DBH,QUERY,ARRAY
621
622 Deprecated, see C<selectcol_array_query>
623
624 =item selectcol_array_query FORM,DBH,QUERY,ARRAY
625
626 Prepares and executes a query using DBUtils functions, retrieves the values of
627 the first result column and returns the values as an array.
628
629 =item selectall_as_map FORM,DBH,QUERY,KEY_COL,VALUE_COL,ARRAY
630
631 Prepares and executes a query using DBUtils functions, retrieves all data from
632 the database, and creates a hash from the results using KEY_COL as the column
633 for the hash keys and VALUE_COL for its values.
634
635 =back
636
637 =head1 UTILITY FUNCTIONS
638
639 =over 4
640
641 =item create_sort_spec
642
643   params:
644     defs        => { },         # mandatory
645     default     => 'name',      # mandatory
646     column      => 'name',
647     default_dir => 0|1,
648     dir         => 0|1,
649
650   returns hash:
651     column      => 'name',
652     dir         => 0|1,
653     sql         => 'SQL code',
654
655 This function simplifies the creation of SQL code for sorting
656 columns. It uses a hashref of valid column names, the column name and
657 direction requested by the user, the application defaults for the
658 column name and the direction and returns the actual column name,
659 direction and SQL code that can be used directly in a query.
660
661 The parameter 'defs' is a hash reference. The keys are the column
662 names as they may come from the application. The values are either
663 scalars with SQL code or array references of SQL code. Example:
664
665   defs => {
666     customername => 'lower(customer.name)',
667     address      => [ 'lower(customer.city)', 'lower(customer.street)' ],
668   }
669
670 'default' is the default column name to sort by. It must be a key of
671 'defs' and should not be come from user input.
672
673 The 'column' parameter is the column name as requested by the
674 application (e.g. if the user clicked on a column header in a
675 report). If it is invalid then the 'default' parameter will be used
676 instead.
677
678 'default_dir' is the default sort direction. A true value means 'sort
679 ascending', a false one 'sort descending'. 'default_dir' defaults to
680 '1' if undefined.
681
682 The 'dir' parameter is the sort direction as requested by the
683 application (e.g. if the user clicked on a column header in a
684 report). If it is undefined then the 'default_dir' parameter will be
685 used instead.
686
687 =back
688
689 =head1 DEBUG FUNCTIONS
690
691 =over 4
692
693 =item dump_query LEVEL,MSG,QUERY,ARRAY
694
695 Dumps a query using LXDebug->message, using LEVEL for the debug-level of
696 LXDebug. If MSG is given, it preceeds the QUERY dump in the logfiles. ARRAY is
697 used to interpolate the '?' placeholders in QUERY, the resulting QUERY can be
698 copy-pasted into a database frontend for debugging. Note that this method is
699 also automatically called by each of the other QUERY FUNCTIONS, so there is in
700 general little need to invoke it manually.
701
702 =back
703
704 =head1 EXAMPLES
705
706 =over 4
707
708 =item Retrieving a whole table:
709
710   $query = qq|SELECT id, pricegroup FROM pricegroup|;
711   $form->{PRICEGROUPS} = selectall_hashref_query($form, $dbh, $query);
712
713 =item Retrieving a single value:
714
715   $query = qq|SELECT nextval('glid')|;
716   ($new_id) = selectrow_query($form, $dbh, $query);
717
718 =item Retrieving all values from a column:
719
720   $query = qq|SELECT id FROM units|;
721   @units = selectcol_array_query($form, $dbh, $query);
722
723 =item Using binding values:
724
725   $query = qq|UPDATE ar SET paid = amount + paid, storno = 't' WHERE id = ?|;
726   do_query($form, $dbh, $query, $id);
727
728 =item A more complicated example, using dynamic binding values:
729
730   my @values;
731
732   if ($form->{language_values} ne "") {
733     $query = qq|
734       SELECT l.id, l.description, tr.translation, tr.longdescription
735       FROM language l
736       LEFT JOIN translation tr ON (tr.language_id = l.id AND tr.parts_id = ?)
737     |;
738     @values = (conv_i($form->{id}));
739   } else {
740     $query = qq|SELECT id, description FROM language|;
741   }
742
743   my $languages = selectall_hashref_query($form, $dbh, $query, @values);
744
745 =back
746
747 =head1 MODULE AUTHORS
748
749   Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
750   Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
751
752 =head1 DOCUMENTATION AUTHORS
753
754   Udo Spallek E<lt>udono@gmx.netE<gt>
755   Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
756
757 =head1 COPYRIGHT AND LICENSE
758
759 Copyright 2007 by kivitendo Community
760
761 This program is free software; you can redistribute it and/or modify
762 it under the terms of the GNU General Public License as published by
763 the Free Software Foundation; either version 2 of the License, or
764 (at your option) any later version.
765
766 This program is distributed in the hope that it will be useful,
767 but WITHOUT ANY WARRANTY; without even the implied warranty of
768 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
769 GNU General Public License for more details.
770 You should have received a copy of the GNU General Public License
771 along with this program; if not, write to the Free Software
772 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
773
774 =cut