X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=a9865577bf40c1f9afbec2086d00adf4b7852391;hp=4d18d8dce68639a69d62d47a54ecbc1f717df28e;hb=f107730c1bc2e5dc08f2990639aaf779cea4605d;hpb=e366f8071f0797f739114539858e59bd3aea3baa

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 4d18d8d..a986557 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -16,6 +16,7 @@ use Data::Dumper::Concise 'Dumper';
 use Sub::Name 'subname';
 use Try::Tiny;
 use File::Path 'make_path';
+use overload ();
 use namespace::clean;
 
 
@@ -54,7 +55,13 @@ __PACKAGE__->mk_group_accessors('simple' => @storage_options);
 # will get the same rdbms version). _determine_supports_X does not need to
 # exist on a driver, as we ->can for it before calling.
 
-my @capabilities = (qw/insert_returning placeholders typeless_placeholders join_optimizer/);
+my @capabilities = (qw/
+  insert_returning
+  insert_returning_bound
+  placeholders
+  typeless_placeholders
+  join_optimizer
+/);
 __PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
 __PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) );
 
@@ -206,6 +213,12 @@ sub DESTROY {
   # some databases spew warnings on implicit disconnect
   local $SIG{__WARN__} = sub {};
   $self->_dbh(undef);
+
+  # this op is necessary, since the very last perl runtime statement
+  # triggers a global destruction shootout, and the $SIG localization
+  # may very well be destroyed before perl actually gets to do the
+  # $dbh undef
+  1;
 }
 
 # handle pid changes correctly - do not destroy parent's connection
@@ -766,7 +779,7 @@ sub txn_do {
   local $self->{_in_dbh_do} = 1;
 
   my @result;
-  my $want_array = wantarray;
+  my $want = wantarray;
 
   my $tried = 0;
   while(1) {
@@ -778,10 +791,10 @@ sub txn_do {
     try {
       $self->txn_begin;
       my $txn_start_depth = $self->transaction_depth;
-      if($want_array) {
+      if($want) {
           @result = $coderef->(@$args);
       }
-      elsif(defined $want_array) {
+      elsif(defined $want) {
           $result[0] = $coderef->(@$args);
       }
       else {
@@ -800,7 +813,7 @@ sub txn_do {
       $exception = $_;
     };
 
-    if(! defined $exception) { return $want_array ? @result : $result[0] }
+    if(! defined $exception) { return wantarray ? @result : $result[0] }
 
     if($self->transaction_depth > 1 || $tried++ || $self->connected) {
       my $rollback_exception;
@@ -1407,7 +1420,10 @@ sub _dbh_begin_work {
 
 sub txn_commit {
   my $self = shift;
-  if ($self->{transaction_depth} == 1) {
+  if (! $self->_dbh) {
+    $self->throw_exception('cannot COMMIT on a disconnected handle');
+  }
+  elsif ($self->{transaction_depth} == 1) {
     $self->debugobj->txn_commit()
       if ($self->debug);
     $self->_dbh_commit;
@@ -1419,6 +1435,17 @@ sub txn_commit {
     $self->svp_release
       if $self->auto_savepoint;
   }
+  elsif (! $self->_dbh->FETCH('AutoCommit') ) {
+
+    carp "Storage transaction_depth $self->{transaction_depth} does not match "
+        ."false AutoCommit of $self->{_dbh}, attempting COMMIT anyway";
+
+    $self->debugobj->txn_commit()
+      if ($self->debug);
+    $self->_dbh_commit;
+    $self->{transaction_depth} = 0
+      if $self->_dbh_autocommit;
+  }
   else {
     $self->throw_exception( 'Refusing to commit without a started transaction' );
   }
@@ -1548,10 +1575,21 @@ sub _dbh_execute {
 
     foreach my $data (@data) {
       my $ref = ref $data;
-      $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
 
-      $sth->bind_param($placeholder_index, $data, $attributes);
-      $placeholder_index++;
+      if ($ref and overload::Method($data, '""') ) {
+        $data = "$data";
+      }
+      elsif ($ref eq 'SCALAR') {  # any scalarrefs are assumed to be bind_inouts
+        $sth->bind_param_inout(
+          $placeholder_index++,
+          $data,
+          $self->_max_column_bytesize($ident, $column_name),
+          $attributes
+        );
+        next;
+      }
+
+      $sth->bind_param($placeholder_index++, $data, $attributes);
     }
   }
 
@@ -1588,7 +1626,7 @@ sub _prefetch_autovalues {
       )
     ) {
       $values{$col} = $self->_sequence_fetch(
-        'nextval',
+        'NEXTVAL',
         ( $colinfo->{$col}{sequence} ||=
             $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
         ),
@@ -1610,19 +1648,19 @@ sub insert {
   # list of primary keys we try to fetch from the database
   # both not-exsists and scalarrefs are considered
   my %fetch_pks;
-  %fetch_pks = ( map
-    { $_ => scalar keys %fetch_pks }  # so we can preserve order for prettyness
-    grep
-      { ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR' }
-      $source->primary_columns
-  );
+  for ($source->primary_columns) {
+    $fetch_pks{$_} = scalar keys %fetch_pks  # so we can preserve order for prettyness
+      if ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR';
+  }
 
-  my $sqla_opts;
+  my ($sqla_opts, @ir_container);
   if ($self->_use_insert_returning) {
 
     # retain order as declared in the resultsource
     for (sort { $fetch_pks{$a} <=> $fetch_pks{$b} } keys %fetch_pks ) {
       push @{$sqla_opts->{returning}}, $_;
+      $sqla_opts->{returning_container} = \@ir_container
+        if $self->_use_insert_returning_bound;
     }
   }
 
@@ -1633,14 +1671,14 @@ sub insert {
   my %returned_cols;
 
   if (my $retlist = $sqla_opts->{returning}) {
-    my @ret_vals = try {
+    @ir_container = try {
       local $SIG{__WARN__} = sub {};
       my @r = $sth->fetchrow_array;
       $sth->finish;
       @r;
-    };
+    } unless @ir_container;
 
-    @returned_cols{@$retlist} = @ret_vals if @ret_vals;
+    @returned_cols{@$retlist} = @ir_container if @ir_container;
   }
 
   return { %$prefetched_values, %returned_cols };
@@ -2001,7 +2039,7 @@ sub _select_args {
     from => $ident,
     where => $where,
     $rs_alias && $alias2source->{$rs_alias}
-      ? ( _rsroot_source_handle => $alias2source->{$rs_alias}->handle )
+      ? ( _rsroot_rsrc => $alias2source->{$rs_alias} )
       : ()
     ,
   };
@@ -2063,9 +2101,7 @@ sub _select_args {
         &&
       @{$attrs->{group_by}}
         &&
-      $attrs->{_prefetch_select}
-        &&
-      @{$attrs->{_prefetch_select}}
+      $attrs->{_prefetch_selector_range}
     )
   ) {
     ($ident, $select, $where, $attrs)
@@ -2635,8 +2671,7 @@ sub deployment_statements {
   );
 
   my @ret;
-  my $wa = wantarray;
-  if ($wa) {
+  if (wantarray) {
     @ret = $tr->translate;
   }
   else {
@@ -2646,7 +2681,7 @@ sub deployment_statements {
   $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
     unless (@ret && defined $ret[0]);
 
-  return $wa ? @ret : $ret[0];
+  return wantarray ? @ret : $ret[0];
 }
 
 sub deploy {
@@ -2771,6 +2806,55 @@ sub relname_to_table_alias {
   return $alias;
 }
 
+# The size in bytes to use for DBI's ->bind_param_inout, this is the generic
+# version and it may be necessary to amend or override it for a specific storage
+# if such binds are necessary.
+sub _max_column_bytesize {
+  my ($self, $source, $col) = @_;
+
+  my $inf = $source->column_info($col);
+  return $inf->{_max_bytesize} ||= do {
+
+    my $max_size;
+
+    if (my $data_type = $inf->{data_type}) {
+      $data_type = lc($data_type);
+
+      # String/sized-binary types
+      if ($data_type =~ /^(?:l?(?:var)?char(?:acter)?(?:\s*varying)?
+                             |(?:var)?binary(?:\s*varying)?|raw)\b/x
+      ) {
+        $max_size = $inf->{size};
+      }
+      # Other charset/unicode types, assume scale of 4
+      elsif ($data_type =~ /^(?:national\s*character(?:\s*varying)?|nchar
+                              |univarchar
+                              |nvarchar)\b/x
+      ) {
+        $max_size = $inf->{size} * 4 if $inf->{size};
+      }
+      # Blob types
+      elsif ($self->_is_lob_type($data_type)) {
+        # default to longreadlen
+      }
+      else {
+        $max_size = 100;  # for all other (numeric?) datatypes
+      }
+    }
+
+    $max_size ||= $self->_get_dbh->{LongReadLen} || 8000;
+  };
+}
+
+# Determine if a data_type is some type of BLOB
+sub _is_lob_type {
+  my ($self, $data_type) = @_;
+  $data_type && ($data_type =~ /(?:lob|bfile|text|image|bytea|memo)/i
+    || $data_type =~ /^long(?:\s*(?:raw|bit\s*varying|varbit|binary
+                                  |varchar|character\s*varying|nvarchar
+                                  |national\s*character\s*varying))?$/xi);
+}
+
 1;
 
 =head1 USAGE NOTES