X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUtils.pm;h=f0952440e4aaa6595fe621eb4e77eee48ca11b46;hb=24af0d9994b2d7e00d740b6bb6e698c68ebc96a4;hp=a20c02661edb953461ed0b0ddaeb5c548d61174c;hpb=12451e347bef2bbcff8dec050255f01fe5a89a3c;p=kivitendo-erp.git diff --git a/SL/DBUtils.pm b/SL/DBUtils.pm index a20c02661..f0952440e 100644 --- a/SL/DBUtils.pm +++ b/SL/DBUtils.pm @@ -1,21 +1,40 @@ package SL::DBUtils; +use SL::Util qw(trim); + require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); + +our @EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement + dump_query quote_db_date like + selectfirst_hashref_query selectfirst_array_query + selectall_hashref_query selectall_array_query selectcol_array_query + selectall_as_map + selectall_ids + prepare_execute_query prepare_query + create_sort_spec does_table_exist + add_token check_trgm); -@EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement - dump_query quote_db_date selectall_hashref_query - selectfirst_hashref_query selectfirst_array_query - prepare_execute_query); +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; + return undef if !defined $value; + $value = trim($value); + return $value eq "" ? undef : $value; } sub conv_dateq { @@ -28,38 +47,57 @@ sub conv_dateq { } sub do_query { + $main::lxdebug->enter_sub(2); + my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + dump_query(LXDebug->QUERY(), '', $query, @_); + my $result; if (0 == scalar(@_)) { - $dbh->do($query) || $form->dberror($query); + $result = $dbh->do($query) || $form->dberror($query); } else { - $dbh->do($query, undef, @_) || - $form->dberror($query . " (" . join(", ", @_) . ")"); + $result = $dbh->do($query, undef, @_) || $form->dberror($query . " (" . join(", ", @_) . ")"); } + + $main::lxdebug->leave_sub(2); + + return $result; } sub selectrow_query { &selectfirst_array_query } sub do_statement { + $main::lxdebug->enter_sub(2); + my ($form, $sth, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + dump_query(LXDebug->QUERY(), '', $query, @_); + my $result; if (0 == scalar(@_)) { - $sth->execute() || $form->dberror($query); + $result = $sth->execute() || $form->dberror($query); } else { - $sth->execute(@_) || - $form->dberror($query . " (" . join(", ", @_) . ")"); + $result = $sth->execute(@_) || $form->dberror($query . " (" . join(", ", @_) . ")"); } + + $main::lxdebug->leave_sub(2); + + return $result; } sub dump_query { my ($level, $msg, $query) = splice(@_, 0, 3); + my $self_filename = 'SL/DBUtils.pm'; + my $filename = $self_filename; + my ($caller_level, $line, $subroutine); + while ($filename =~ m{$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/; @@ -69,7 +107,9 @@ sub dump_query { $msg .= " " if ($msg); - $main::lxdebug->message($level, $msg . $query); + my $info = "$subroutine called from $filename:$line\n"; + + $main::lxdebug->message($level, $info . $msg . $query); } sub quote_db_date { @@ -78,14 +118,30 @@ sub quote_db_date { return "NULL" unless defined $str; return "current_date" if $str =~ /current_date/; - $str =~ s/'/''/g; + $str =~ s/\'/\'\'/g; return "'$str'"; } +sub prepare_query { + $main::lxdebug->enter_sub(2); + + my ($form, $dbh, $query) = splice(@_, 0, 3); + + dump_query(LXDebug->QUERY(), '', $query, @_); + + my $sth = $dbh->prepare($query) || $form->dberror($query); + + $main::lxdebug->leave_sub(2); + + return $sth; +} + sub prepare_execute_query { + $main::lxdebug->enter_sub(2); + my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + dump_query(LXDebug->QUERY(), '', $query, @_); my $sth = $dbh->prepare($query) || $form->dberror($query); if (scalar(@_) != 0) { @@ -94,65 +150,283 @@ sub prepare_execute_query { $sth->execute() || $form->dberror($query); } + $main::lxdebug->leave_sub(2); + return $sth; } sub selectall_hashref_query { + $main::lxdebug->enter_sub(2); + my ($form, $dbh, $query) = splice(@_, 0, 3); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + 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); + + return wantarray ? @{ $result } : $result; +} + +sub selectall_array_query { goto &selectcol_array_query; } + +sub selectcol_array_query { + $main::lxdebug->enter_sub(2); + + 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); - } + my @result = @{ $dbh->selectcol_arrayref($sth) }; $sth->finish(); - return $result; + $main::lxdebug->leave_sub(2); + + return @result; } sub selectfirst_hashref_query { - my ($form, $dbh, $query) = splice(@_, 0, 3); + $main::lxdebug->enter_sub(2); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + my ($form, $dbh, $query) = splice(@_, 0, 3); my $sth = prepare_execute_query($form, $dbh, $query, @_); my $ref = $sth->fetchrow_hashref(); $sth->finish(); + $main::lxdebug->leave_sub(2); + return $ref; } sub selectfirst_array_query { - my ($form, $dbh, $query) = splice(@_, 0, 3); + $main::lxdebug->enter_sub(2); - dump_query(LXDebug::QUERY, '', $query . " (" . join(", ", @_) . ")", @_); + my ($form, $dbh, $query) = splice(@_, 0, 3); my $sth = prepare_execute_query($form, $dbh, $query, @_); my @ret = $sth->fetchrow_array(); $sth->finish(); + $main::lxdebug->leave_sub(2); + return @ret; } +sub selectall_as_map { + $main::lxdebug->enter_sub(2); + + my ($form, $dbh, $query, $key_col, $value_col) = splice(@_, 0, 5); + + my $sth = prepare_execute_query($form, $dbh, $query, @_); + + my %hash; + if ('' eq ref $value_col) { + while (my $ref = $sth->fetchrow_hashref()) { + $hash{$ref->{$key_col} // ''} = $ref->{$value_col}; + } + } else { + while (my $ref = $sth->fetchrow_hashref()) { + $hash{$ref->{$key_col} // ''} = { map { $_ => $ref->{$_} } @{ $value_col } }; + } + } + + $sth->finish(); + + $main::lxdebug->leave_sub(2); + + return %hash; +} + +sub selectall_ids { + $main::lxdebug->enter_sub(2); + + my ($form, $dbh, $query, $key_col) = splice(@_, 0, 4); + + my $sth = prepare_execute_query($form, $dbh, $query, @_); + + my @ids; + while (my $ref = $sth->fetchrow_arrayref()) { + push @ids, $ref->[$key_col]; + } + + $sth->finish; + + $main::lxdebug->leave_sub(2); + + return @ids; +} + +sub create_sort_spec { + $main::lxdebug->enter_sub(2); + + my %params = @_; + + # Safety check: + $params{defs} || die; + $params{default} || die; + + # The definition of valid columns to sort by. + my $defs = $params{defs}; + + # The column name to sort by. Use the default column name if none was given. + my %result = ( 'column' => $params{column} || $params{default} ); + + # Overwrite the column name with the default column name if the other one is not valid. + $result{column} = $params{default} unless ($defs->{ $result{column} }); + + # The sort direction. true means 'sort ascending', false means 'sort descending'. + $result{dir} = defined $params{dir} ? $params{dir} + : defined $params{default_dir} ? $params{default_dir} + : 1; + $result{dir} = $result{dir} ? 1 : 0; + my $asc_desc = $result{dir} ? 'ASC' : 'DESC'; + + # Create the SQL code. + my $cols = $defs->{ $result{column} }; + $result{sql} = join ', ', map { "${_} ${asc_desc}" } @{ ref $cols eq 'ARRAY' ? $cols : [ $cols ] }; + + $main::lxdebug->leave_sub(2); + + return %result; +} + +sub does_table_exist { + $main::lxdebug->enter_sub(2); + + my $dbh = shift; + my $table = shift; + + my $result = 0; + + if ($dbh) { + my $sth = $dbh->table_info('', '', $table, 'TABLE'); + if ($sth) { + $result = $sth->fetchrow_hashref(); + $sth->finish(); + } + } + + $main::lxdebug->leave_sub(2); + + 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 { trim($_[0]) . '%' }, + end => sub { '%' . trim($_[0]) }, + substr => sub { like($_[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); +} + +sub like { + my ($string) = @_; + + return "%" . SL::Util::trim($string // '') . "%"; +} + +sub role_is_superuser { + my ($dbh, $login) = @_; + my ($is_superuser) = $dbh->selectrow_array(qq|SELECT usesuper FROM pg_user WHERE usename = ?|, undef, $login); + + return $is_superuser; +} + +sub check_trgm { + my ($dbh) = @_; + + my $version = $dbh->selectrow_array(qq|SELECT installed_version FROM pg_available_extensions WHERE name = 'pg_trgm'|); + + return !!$version; +} + 1; __END__ +=encoding utf-8 + =head1 NAME -SL::DBUTils.pm: All about Databaseconections in Lx +SL::DBUtils.pm: All about database connections in kivitendo =head1 SYNOPSIS use DBUtils; - - conv_i - conv_date - conv_dateq - quote_db_date($str) + + conv_i($str, $default) + conv_date($str) + conv_dateq($str) + quote_db_date($date) + + my $dbh = SL::DB->client->dbh; do_query($form, $dbh, $query) do_statement($form, $sth, $query) @@ -162,58 +436,340 @@ 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 = selectfirst_array_query($form, $dbh, $query); my @first_result = selectrow_query($form, $dbh, $query); - - + + my @values = selectcol_array_query($form, $dbh, $query); + + my %sort_spec = create_sort_spec(%params); + =head1 DESCRIPTION - -=head1 FUNCTIONS - + +DBUtils provides wrapper functions for low level database retrieval. It saves +you the trouble of mucking around with statement handles for small database +queries and does exception handling in the common cases for you. + +Query and retrieval functions share the parameter scheme: + + query_or_retrieval(C