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