Bei Verwendung von SMTP nicht doppelt nach UTF-8 encoden

[mfinanz.git] / SL / DBUtils.pm

diff --git a/SL/DBUtils.pm b/SL/DBUtils.pm
index f2e99a8e398794f98df950241f63b218ff13bb9c..1f243bcfd804b079abb17c8635e6a036bf7296d1 100644 (file)
--- a/SL/DBUtils.pm
+++ b/SL/DBUtils.pm
@@ -1,9 +1,9 @@
 package SL::DBUtils;
 
 require Exporter;
 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
              dump_query quote_db_date
              selectfirst_hashref_query selectfirst_array_query
              selectall_hashref_query selectall_array_query


@@ -12,11 +12,21 @@ require Exporter;
              create_sort_spec does_table_exist
              add_token);
 
              create_sort_spec does_table_exist
              add_token);
 

+use strict;
+

 sub conv_i {
   my ($value, $default) = @_;
   return (defined($value) && "$value" ne "") ? $value * 1 : $default;
 }
 
 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;
 sub conv_date {
   my ($value) = @_;
   return (defined($value) && "$value" ne "") ? $value : undef;


@@ -36,7 +46,7 @@ sub do_query {
 
   my ($form, $dbh, $query) = splice(@_, 0, 3);
 
 
   my ($form, $dbh, $query) = splice(@_, 0, 3);
 

-  dump_query(LXDebug::QUERY, '', $query, @_);
+  dump_query(LXDebug->QUERY(), '', $query, @_);

 
   my $result;
   if (0 == scalar(@_)) {
 
   my $result;
   if (0 == scalar(@_)) {


@@ -57,7 +67,7 @@ sub do_statement {
 
   my ($form, $sth, $query) = splice(@_, 0, 3);
 
 
   my ($form, $sth, $query) = splice(@_, 0, 3);
 

-  dump_query(LXDebug::QUERY, '', $query, @_);
+  dump_query(LXDebug->QUERY(), '', $query, @_);

 
   my $result;
   if (0 == scalar(@_)) {
 
   my $result;
   if (0 == scalar(@_)) {


@@ -74,14 +84,15 @@ sub do_statement {
 sub dump_query {
   my ($level, $msg, $query) = splice(@_, 0, 3);
 
 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 =~ /\?/) {
   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/;
     $value =~ s/\'/\\\'/g;
     $value = "'${value}'";
     $query =~ s/\?/$value/;


@@ -111,7 +122,7 @@ sub prepare_query {
 
   my ($form, $dbh, $query) = splice(@_, 0, 3);
 
 
   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);
 
 
   my $sth = $dbh->prepare($query) || $form->dberror($query);
 


@@ -125,7 +136,7 @@ sub prepare_execute_query {
 
   my ($form, $dbh, $query) = splice(@_, 0, 3);
 
 
   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) {
 
   my $sth = $dbh->prepare($query) || $form->dberror($query);
   if (scalar(@_) != 0) {


@@ -144,12 +155,11 @@ sub selectall_hashref_query {
 
   my ($form, $dbh, $query) = splice(@_, 0, 3);
 
 
   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);
 
 
   $main::lxdebug->leave_sub(2);
 


@@ -305,16 +315,29 @@ sub add_token {
   my %params = @_;
   my $col    = $params{col};
   my $val    = $params{val};
   my %params = @_;
   my $col    = $params{col};
   my $val    = $params{val};

-  my $method = $params{method} || '=';

   my $escape = $params{esc} || sub { $_ };
   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,
 
   $val = [ $val ] unless ref $val eq 'ARRAY';
 
   my %escapes = (
     id     => \&conv_i,

+    bool   => \&conv_b,

     date   => \&conv_date,
     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;
   my %methods = (
     '=' => sub {
       my $col = shift;


@@ -322,6 +345,7 @@ sub add_token {
            : scalar @_ == 1 ? sprintf '%s = ?',     $col
            :                  undef;
     },
            : scalar @_ == 1 ? sprintf '%s = ?',     $col
            :                  undef;
     },

+    map({ $_ => $_long_token->($_) } qw(LIKE ILIKE >= <= > <)),

   );
 
   $method = $methods{$method} || $method;
   );
 
   $method = $methods{$method} || $method;


@@ -555,8 +579,6 @@ Dumps a query using LXDebug->message, using LEVEL for the debug-level of LXDebug
 
 =back
 
 
 =back
 

-=head1 SEE ALSO
-

 =head1 MODULE AUTHORS
 
 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 =head1 MODULE AUTHORS
 
 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>


@@ -583,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.
 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