Switch from using execute_array to execute_for_fetch directly
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm
index 2b95463..607b1ef 100644 (file)
@@ -325,8 +325,8 @@ for most DBDs. See L</DBIx::Class and AutoCommit> for details.
 
 =head3 DBIx::Class specific connection attributes
 
-In addition to the standard L<DBI|DBI/ATTRIBUTES_COMMON_TO_ALL_HANDLES>
-L<connection|DBI/Database_Handle_Attributes> attributes, DBIx::Class recognizes
+In addition to the standard L<DBI|DBI/ATTRIBUTES COMMON TO ALL HANDLES>
+L<connection|DBI/Database Handle Attributes> attributes, DBIx::Class recognizes
 the following connection options. These options can be mixed in with your other
 L<DBI> connection attributes, or placed in a separate hashref
 (C<\%extra_attributes>) as shown above.
@@ -1360,7 +1360,7 @@ sub txn_commit {
   # as a new txn is started immediately on commit
   $self->transaction_depth(1) if (
     !$self->transaction_depth
-      and 
+      and
     defined $self->_dbh_autocommit
       and
     ! $self->_dbh_autocommit
@@ -1391,7 +1391,7 @@ sub txn_rollback {
   # as a new txn is started immediately on commit
   $self->transaction_depth(1) if (
     !$self->transaction_depth
-      and 
+      and
     defined $self->_dbh_autocommit
       and
     ! $self->_dbh_autocommit
@@ -1430,42 +1430,70 @@ sub _gen_sql_bind {
     @$args,
   );
 
-  my (@final_bind, $colinfos);
+  if (
+    ! $ENV{DBIC_DT_SEARCH_OK}
+      and
+    $op eq 'select'
+      and
+    first { blessed($_->[1]) && $_->[1]->isa('DateTime') } @bind
+  ) {
+    carp_unique 'DateTime objects passed to search() are not supported '
+      . 'properly (InflateColumn::DateTime formats and settings are not '
+      . 'respected.) See "Formatting DateTime objects in queries" in '
+      . 'DBIx::Class::Manual::Cookbook. To disable this warning for good '
+      . 'set $ENV{DBIC_DT_SEARCH_OK} to true'
+  }
+
+  return( $sql, $self->_resolve_bindattrs(
+    $ident, [ @{$args->[2]{bind}||[]}, @bind ]
+  ));
+}
+
+sub _resolve_bindattrs {
+  my ($self, $ident, $bind, $colinfos) = @_;
+
+  $colinfos ||= {};
+
   my $resolve_bindinfo = sub {
-    $colinfos ||= $self->_resolve_column_info($ident);
-    if (my $col = $_[1]->{dbic_colname}) {
-      $_[1]->{sqlt_datatype} ||= $colinfos->{$col}{data_type}
+    #my $infohash = shift;
+
+    %$colinfos = %{ $self->_resolve_column_info($ident) }
+      unless keys %$colinfos;
+
+    my $ret;
+    if (my $col = $_[0]->{dbic_colname}) {
+      $ret = { %{$_[0]} };
+
+      $ret->{sqlt_datatype} ||= $colinfos->{$col}{data_type}
         if $colinfos->{$col}{data_type};
-      $_[1]->{sqlt_size} ||= $colinfos->{$col}{size}
+
+      $ret->{sqlt_size} ||= $colinfos->{$col}{size}
         if $colinfos->{$col}{size};
     }
-    $_[1];
-  };
 
-  for my $e (@{$args->[2]{bind}||[]}, @bind) {
-    push @final_bind, [ do {
-      if (ref $e ne 'ARRAY') {
-        ({}, $e)
-      }
-      elsif (! defined $e->[0]) {
-        ({}, $e->[1])
-      }
-      elsif (ref $e->[0] eq 'HASH') {
-        (
-          (first { $e->[0]{$_} } qw/dbd_attrs sqlt_datatype/) ? $e->[0] : $self->$resolve_bindinfo($e->[0]),
-          $e->[1]
-        )
-      }
-      elsif (ref $e->[0] eq 'SCALAR') {
-        ( { sqlt_datatype => ${$e->[0]} }, $e->[1] )
-      }
-      else {
-        ( $self->$resolve_bindinfo({ dbic_colname => $e->[0] }), $e->[1] )
-      }
-    }];
-  }
+    $ret || $_[0];
+  };
 
-  ($sql, \@final_bind);
+  return [ map {
+    if (ref $_ ne 'ARRAY') {
+      [{}, $_]
+    }
+    elsif (! defined $_->[0]) {
+      [{}, $_->[1]]
+    }
+    elsif (ref $_->[0] eq 'HASH') {
+      [
+        ($_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) ? $_->[0] : $resolve_bindinfo->($_->[0]),
+        $_->[1]
+      ]
+    }
+    elsif (ref $_->[0] eq 'SCALAR') {
+      [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ]
+    }
+    else {
+      [ $resolve_bindinfo->({ dbic_colname => $_->[0] }), $_->[1] ]
+    }
+  } @$bind ];
 }
 
 sub _format_for_trace {
@@ -1529,7 +1557,13 @@ sub _dbi_attrs_for_bind {
         $_->{dbd_attrs}
       }
       elsif($_->{sqlt_datatype}) {
-        $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+        # cache the result in the dbh_details hash, as it can not change unless
+        # we connect to something else
+        my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
+        if (not exists $cache->{$_->{sqlt_datatype}}) {
+          $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+        }
+        $cache->{$_->{sqlt_datatype}};
       }
       elsif ($sba_attrs and $_->{dbic_colname}) {
         $sba_attrs->{$_->{dbic_colname}} || undef;
@@ -1837,8 +1871,8 @@ sub insert_bulk {
     $self->throw_exception('Cannot insert_bulk without support for placeholders');
   }
 
-  # neither _execute_array, nor _execute_inserts_with_no_binds are
-  # atomic (even if _execute _array is a single call). Thus a safety
+  # neither _dbh_execute_for_fetch, nor _dbh_execute_inserts_with_no_binds
+  # are atomic (even if execute_for_fetch is a single call). Thus a safety
   # scope guard
   my $guard = $self->txn_scope_guard;
 
@@ -1848,7 +1882,7 @@ sub insert_bulk {
     if (@$proto_bind) {
       # proto bind contains the information on which pieces of $data to pull
       # $cols is passed in only for prettier error-reporting
-      $self->_execute_array( $source, $sth, $proto_bind, $cols, $data );
+      $self->_dbh_execute_for_fetch( $source, $sth, $proto_bind, $cols, $data );
     }
     else {
       # bind_param_array doesn't work if there are no binds
@@ -1863,37 +1897,56 @@ sub insert_bulk {
   return (wantarray ? ($rv, $sth, @$proto_bind) : $rv);
 }
 
-sub _execute_array {
-  my ($self, $source, $sth, $proto_bind, $cols, $data, @extra) = @_;
+# execute_for_fetch is capable of returning data just fine (it means it
+# can be used for INSERT...RETURNING and UPDATE...RETURNING. Since this
+# is the void-populate fast-path we will just ignore this altogether
+# for the time being.
+sub _dbh_execute_for_fetch {
+  my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
 
-  ## This must be an arrayref, else nothing works!
-  my $tuple_status = [];
+  my @idx_range = ( 0 .. $#$proto_bind );
 
-  my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
+  # If we have any bind attributes to take care of, we will bind the
+  # proto-bind data (which will never be used by execute_for_fetch)
+  # However since column bindtypes are "sticky", this is sufficient
+  # to get the DBD to apply the bindtype to all values later on
 
-  # Bind the values by column slices
-  for my $i (0 .. $#$proto_bind) {
-    my $data_slice_idx = (
-      ref $proto_bind->[$i][0] eq 'HASH'
-        and
-      exists $proto_bind->[$i][0]{_bind_data_slice_idx}
-    ) ? $proto_bind->[$i][0]{_bind_data_slice_idx} : undef;
+  my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
 
-    $sth->bind_param_array(
+  for my $i (@idx_range) {
+    $sth->bind_param (
       $i+1, # DBI bind indexes are 1-based
-      defined $data_slice_idx
-        # either get a "column" of dynamic values, or just repeat the same
-        # bind over and over
-        ? [ map { $_->[$data_slice_idx] } @$data ]
-        : [ ($proto_bind->[$i][1]) x @$data ]
-      ,
-      defined $bind_attrs->[$i] ? $bind_attrs->[$i] : (), # some DBDs throw up when given an undef
-    );
+      $proto_bind->[$i][1],
+      $bind_attrs->[$i],
+    ) if defined $bind_attrs->[$i];
   }
 
+  my $data_slice_idx = [ map {
+    (
+      ref $proto_bind->[$_][0] eq 'HASH'
+        and
+      exists $proto_bind->[$_][0]{_bind_data_slice_idx}
+    ) ? $proto_bind->[$_][0]{_bind_data_slice_idx} : undef;
+  } @idx_range ];
+
+  my $fetch_row_idx = -1; # saner loop this way
+  my $fetch_tuple = sub {
+    return undef if ++$fetch_row_idx > $#$data;
+
+    return [ map {
+      defined $data_slice_idx->[$_]
+        ? $data->[$fetch_row_idx][$data_slice_idx->[$_]]
+        : $proto_bind->[$_][1]
+    } @idx_range ];
+  };
+
+  my $tuple_status = [];
   my ($rv, $err);
   try {
-    $rv = $self->_dbh_execute_array($sth, $tuple_status, @extra);
+    $rv = $sth->execute_for_fetch(
+      $fetch_tuple,
+      $tuple_status,
+    );
   }
   catch {
     $err = shift;
@@ -1923,7 +1976,7 @@ sub _execute_array {
       if ($i > $#$tuple_status);
 
     require Data::Dumper::Concise;
-    $self->throw_exception(sprintf "execute_array() aborted with '%s' at populate slice:\n%s",
+    $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s",
       ($tuple_status->[$i][1] || $err),
       Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
     );
@@ -1932,11 +1985,6 @@ sub _execute_array {
   return $rv;
 }
 
-sub _dbh_execute_array {
-  #my ($self, $sth, $tuple_status, @extra) = @_;
-  return $_[1]->execute_array({ArrayTupleStatus => $_[2]});
-}
-
 sub _dbh_execute_inserts_with_no_binds {
   my ($self, $sth, $count) = @_;
 
@@ -2227,16 +2275,6 @@ storage driver. Can be overridden by supplying an explicit L</limit_dialect>
 to L<DBIx::Class::Schema/connect>. For a list of available limit dialects
 see L<DBIx::Class::SQLMaker::LimitDialects>.
 
-=head2 sth
-
-=over 4
-
-=item Arguments: $sql
-
-=back
-
-Returns a L<DBI> sth (statement handle) for the supplied SQL.
-
 =cut
 
 sub _dbh_sth {
@@ -2873,7 +2911,7 @@ sub _max_column_bytesize {
       if ($data_type =~ /^(?:
           l? (?:var)? char(?:acter)? (?:\s*varying)?
             |
-          (?:var)? binary (?:\s*varying)? 
+          (?:var)? binary (?:\s*varying)?
             |
           raw
         )\b/x