X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUtils.pm;h=1f243bcfd804b079abb17c8635e6a036bf7296d1;hb=3b4068e20d8f7b044b9f85eccacac99ba3d453b3;hp=49e9aaeb59a4464c7322fb49cf0d64144de8a1b3;hpb=32147d43441f0a99e6e320f6aaeb6b68e766264f;p=kivitendo-erp.git diff --git a/SL/DBUtils.pm b/SL/DBUtils.pm index 49e9aaeb5..1f243bcfd 100644 --- a/SL/DBUtils.pm +++ b/SL/DBUtils.pm @@ -1,21 +1,32 @@ package SL::DBUtils; require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -@EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement +our @EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement dump_query quote_db_date selectfirst_hashref_query selectfirst_array_query selectall_hashref_query selectall_array_query selectall_as_map prepare_execute_query prepare_query - create_sort_spec does_table_exist); + create_sort_spec does_table_exist + add_token); + +use strict; sub conv_i { my ($value, $default) = @_; return (defined($value) && "$value" ne "") ? $value * 1 : $default; } +# boolean escape +sub conv_b { + my ($value, $default) = @_; + return !defined $value && defined $default ? $default + : $value ? 't' + : 'f'; +} + sub conv_date { my ($value) = @_; return (defined($value) && "$value" ne "") ? $value : undef; @@ -35,7 +46,7 @@ sub do_query { my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query, @_); + dump_query(LXDebug->QUERY(), '', $query, @_); my $result; if (0 == scalar(@_)) { @@ -56,7 +67,7 @@ sub do_statement { my ($form, $sth, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query, @_); + dump_query(LXDebug->QUERY(), '', $query, @_); my $result; if (0 == scalar(@_)) { @@ -73,14 +84,15 @@ sub do_statement { sub dump_query { my ($level, $msg, $query) = splice(@_, 0, 3); - my $filename = $self_filename = 'SL/DBUtils.pm'; - my $caller_level; + my $self_filename = 'SL/DBUtils.pm'; + my $filename = $self_filename; + my ($caller_level, $line, $subroutine); while ($filename eq $self_filename) { (undef, $filename, $line, $subroutine) = caller $caller_level++; } while ($query =~ /\?/) { - my $value = shift(@_); + my $value = shift || ''; $value =~ s/\'/\\\'/g; $value = "'${value}'"; $query =~ s/\?/$value/; @@ -110,7 +122,7 @@ sub prepare_query { my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query, @_); + dump_query(LXDebug->QUERY(), '', $query, @_); my $sth = $dbh->prepare($query) || $form->dberror($query); @@ -124,7 +136,7 @@ sub prepare_execute_query { my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query, @_); + dump_query(LXDebug->QUERY(), '', $query, @_); my $sth = $dbh->prepare($query) || $form->dberror($query); if (scalar(@_) != 0) { @@ -143,12 +155,11 @@ sub selectall_hashref_query { my ($form, $dbh, $query) = splice(@_, 0, 3); - my $sth = prepare_execute_query($form, $dbh, $query, @_); - my $result = []; - while (my $ref = $sth->fetchrow_hashref()) { - push(@{ $result }, $ref); - } - $sth->finish(); + dump_query(LXDebug->QUERY(), '', $query, @_); + + # this works back 'til at least DBI 1.46 on perl 5.8.4 on Debian Sarge (2004) + my $result = $dbh->selectall_arrayref($query, { Slice => {} }, @_) + or $form->dberror($query . (@_ ? " (" . join(", ", @_) . ")" : '')); $main::lxdebug->leave_sub(2); @@ -280,6 +291,76 @@ sub does_table_exist { return $result; } +# add token to values. +# usage: +# add_token( +# \@where_tokens, +# \@where_values, +# col => 'id', +# val => [ 23, 34, 17 ] +# esc => \&conf_i +# ) +# will append to the given arrays: +# -> 'id IN (?, ?, ?)' +# -> (conv_i(23), conv_i(34), conv_i(17)) +# +# features: +# - don't care if one or multiple values are given. singlewill result in 'col = ?' +# - pass escape routines +# - expand for future method +# - no need to type "push @where_tokens, 'id = ?'" over and over again +sub add_token { + my $tokens = shift() || []; + my $values = shift() || []; + my %params = @_; + my $col = $params{col}; + my $val = $params{val}; + my $escape = $params{esc} || sub { $_ }; + my $method = $params{esc} =~ /^start|end|substr$/ ? 'ILIKE' : $params{method} || '='; + + $val = [ $val ] unless ref $val eq 'ARRAY'; + + my %escapes = ( + id => \&conv_i, + bool => \&conv_b, + date => \&conv_date, + start => sub { $_[0] . '%' }, + end => sub { '%' . $_[0] }, + substr => sub { '%' . $_[0] . '%' }, + ); + + my $_long_token = sub { + my $op = shift; + sub { + my $col = shift; + return scalar @_ ? join ' OR ', ("$col $op ?") x scalar @_, + : undef; + } + }; + + my %methods = ( + '=' => sub { + my $col = shift; + return scalar @_ > 1 ? sprintf '%s IN (%s)', $col, join ', ', ("?") x scalar @_ + : scalar @_ == 1 ? sprintf '%s = ?', $col + : undef; + }, + map({ $_ => $_long_token->($_) } qw(LIKE ILIKE >= <= > <)), + ); + + $method = $methods{$method} || $method; + $escape = $escapes{$escape} || $escape; + + my $token = $method->($col, @{ $val }); + my @vals = map { $escape->($_) } @{ $val }; + + return unless $token; + + push @{ $tokens }, $token; + push @{ $values }, @vals; + + return ($token, @vals); +} 1; @@ -293,7 +374,7 @@ SL::DBUTils.pm: All about Databaseconections in Lx =head1 SYNOPSIS use DBUtils; - + conv_i($str, $default) conv_date($str) conv_dateq($str) @@ -307,10 +388,10 @@ SL::DBUTils.pm: All about Databaseconections in Lx my $all_results_ref = selectall_hashref_query($form, $dbh, $query) my $first_result_hash_ref = selectfirst_hashref_query($form, $dbh, $query); - + my @first_result = selectfirst_array_query($form, $dbh, $query); # == my @first_result = selectrow_query($form, $dbh, $query); - + my %sort_spec = create_sort_spec(%params); =head1 DESCRIPTION @@ -329,8 +410,8 @@ Every function here should accomplish the follwing things: - Safe value binding. Although DBI is far from perfect in terms of binding, the rest of the bindings should happen here. - Error handling. Should a query fail, an error message will be generated here instead of in the backend code invoking DBUtils. -Note that binding is not perfect here either... - +Note that binding is not perfect here either... + =head2 QUOTING FUNCTIONS =over 4 @@ -386,11 +467,11 @@ Prepares and executes QUERY on DBH using DBI::prepare and DBI::execute. ARRAY is =item selectrow_query FORM,DBH,QUERY,ARRAY -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. +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. =item selectfirst_hashref_query FORM,DBH,QUERY,ARRAY -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. +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. =item selectall_hashref_query FORM,DBH,QUERY,ARRAY @@ -484,7 +565,7 @@ Dumps a query using LXDebug->message, using LEVEL for the debug-level of LXDebug =item A more complicated example, using dynamic binding values: my @values; - + if ($form->{language_values} ne "") { $query = qq|SELECT l.id, l.description, tr.translation, tr.longdescription FROM language l @@ -493,18 +574,16 @@ Dumps a query using LXDebug->message, using LEVEL for the debug-level of LXDebug } else { $query = qq|SELECT id, description FROM language|; } - + my $languages = selectall_hashref_query($form, $dbh, $query, @values); =back -=head1 SEE ALSO - =head1 MODULE AUTHORS Moritz Bunkus Em.bunkus@linet-services.deE Sven Schoeling Es.schoeling@linet-services.deE - + =head1 DOCUMENTATION AUTHORS Udo Spallek Eudono@gmx.netE @@ -526,4 +605,5 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -=cut + +=cut