X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUtils.pm;h=f0952440e4aaa6595fe621eb4e77eee48ca11b46;hb=9dfd320ff258071e3ad78dd6cf2d76e215efd4f7;hp=19346eb8139a185a8c186ff2f5e2a86b40d14c14;hpb=58a1b54b6a04d70fda952ca86bc3b85b866264e9;p=kivitendo-erp.git diff --git a/SL/DBUtils.pm b/SL/DBUtils.pm index 19346eb81..f0952440e 100644 --- a/SL/DBUtils.pm +++ b/SL/DBUtils.pm @@ -1,23 +1,40 @@ package SL::DBUtils; +use SL::Util qw(trim); + require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -@EXPORT = qw(conv_i conv_date conv_dateq do_query selectrow_query do_statement - dump_query quote_db_date +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 + selectall_hashref_query selectall_array_query selectcol_array_query selectall_as_map - prepare_execute_query prepare_query); + selectall_ids + prepare_execute_query prepare_query + create_sort_spec does_table_exist + add_token check_trgm); + +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 { @@ -34,16 +51,18 @@ 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(@_)) { - $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 } @@ -53,29 +72,32 @@ 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(@_)) { - $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 $filename = $self_filename = 'SL/DBUtils.pm'; - my $caller_level; - while ($filename eq $self_filename) { + 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/; @@ -105,7 +127,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); @@ -119,7 +141,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) { @@ -138,28 +160,26 @@ 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); - return $result; + return wantarray ? @{ $result } : $result; } -sub selectall_array_query { +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 ($value) = $sth->fetchrow_array()) { - push(@result, $value); - } + my @result = @{ $dbh->selectcol_arrayref($sth) }; $sth->finish(); $main::lxdebug->leave_sub(2); @@ -205,11 +225,11 @@ sub selectall_as_map { my %hash; if ('' eq ref $value_col) { while (my $ref = $sth->fetchrow_hashref()) { - $hash{$ref->{$key_col}} = $ref->{$value_col}; + $hash{$ref->{$key_col} // ''} = $ref->{$value_col}; } } else { while (my $ref = $sth->fetchrow_hashref()) { - $hash{$ref->{$key_col}} = { map { $_ => $ref->{$_} } @{ $value_col } }; + $hash{$ref->{$key_col} // ''} = { map { $_ => $ref->{$_} } @{ $value_col } }; } } @@ -220,24 +240,194 @@ sub selectall_as_map { 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($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) @@ -246,30 +436,108 @@ 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 -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. +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