X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=ac841765c811e46d6952939b572fd52fd88b326d;hb=c9733800;hp=8abcc6ece5d694ed4e8d67c569900ec708cffded;hpb=be64931c710bcde7abe7334349b4c8a123645332;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 8abcc6e..ac84176 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -12,9 +12,11 @@ use DBIx::Class::Exception;
 use Scalar::Util qw/refaddr weaken reftype blessed/;
 use List::Util qw/first/;
 use Sub::Name 'subname';
+use Context::Preserve 'preserve_context';
 use Try::Tiny;
 use overload ();
 use Data::Compare (); # no imports!!! guard against insane architecture
+use DBI::Const::GetInfoType (); # no import of retarded global hash
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -34,6 +36,7 @@ __PACKAGE__->sql_name_sep('.');
 __PACKAGE__->mk_group_accessors('simple' => qw/
   _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
   _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
+  _perform_autoinc_retrieval _autoinc_supplied_for_op
 /);
 
 # the values for these accessors are picked out (and deleted) from
@@ -230,6 +233,7 @@ sub DESTROY {
   my $self = shift;
 
   # some databases spew warnings on implicit disconnect
+  $self->_verify_pid;
   local $SIG{__WARN__} = sub {};
   $self->_dbh(undef);
 
@@ -778,37 +782,28 @@ Example:
 
 sub dbh_do {
   my $self = shift;
-  my $code = shift;
-
-  my $dbh = $self->_get_dbh;
-
-  return $self->$code($dbh, @_)
-    if ( $self->{_in_do_block} || $self->{transaction_depth} );
+  my $run_target = shift;
 
-  local $self->{_in_do_block} = 1;
+  # short circuit when we know there is no need for a runner
+  #
+  # FIXME - asumption may be wrong
+  # the rationale for the txn_depth check is that if this block is a part
+  # of a larger transaction, everything up to that point is screwed anyway
+  return $self->$run_target($self->_get_dbh, @_)
+    if $self->{_in_do_block} or $self->transaction_depth;
 
-  # take a ref instead of a copy, to preserve coderef @_ aliasing semantics
   my $args = \@_;
 
-  try {
-    $self->$code ($dbh, @$args);
-  } catch {
-    $self->throw_exception($_) if $self->connected;
-
-    # We were not connected - reconnect and retry, but let any
-    #  exception fall right through this time
-    carp "Retrying dbh_do($code) after catching disconnected exception: $_"
-      if $ENV{DBIC_STORAGE_RETRY_DEBUG};
-
-    $self->_populate_dbh;
-    $self->$code($self->_dbh, @$args);
-  };
+  DBIx::Class::Storage::BlockRunner->new(
+    storage => $self,
+    run_code => sub { $self->$run_target ($self->_get_dbh, @$args ) },
+    wrap_txn => 0,
+    retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
+  )->run;
 }
 
 sub txn_do {
-  # connects or reconnects on pid change, necessary to grab correct txn_depth
-  $_[0]->_get_dbh;
-  local $_[0]->{_in_do_block} = 1;
+  $_[0]->_get_dbh; # connects or reconnects on pid change, necessary to grab correct txn_depth
   shift->next::method(@_);
 }
 
@@ -1080,7 +1075,16 @@ sub _server_info {
 
     $info = {};
 
-    my $server_version = try { $self->_get_server_version };
+    my $server_version;
+    try {
+      $server_version = $self->_get_server_version;
+    }
+    catch {
+      if ($self->{_in_determine_driver}) {
+        $self->throw_exception($_);
+      }
+      $server_version = undef;
+    };
 
     if (defined $server_version) {
       $info->{dbms_version} = $server_version;
@@ -1112,13 +1116,31 @@ sub _server_info {
 }
 
 sub _get_server_version {
-  shift->_dbh_get_info(18);
+  shift->_dbh_get_info('SQL_DBMS_VER');
 }
 
 sub _dbh_get_info {
   my ($self, $info) = @_;
 
-  return try { $self->_get_dbh->get_info($info) } || undef;
+  if ($info =~ /[^0-9]/) {
+    $info = $DBI::Const::GetInfoType::GetInfoType{$info};
+    $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
+      unless defined $info;
+  }
+
+  my $res;
+
+  try {
+    $res = $self->_get_dbh->get_info($info);
+  }
+  catch {
+    if ($self->{_in_determine_driver}) {
+      $self->throw_exception($_);
+    }
+    $res = undef;
+  };
+
+  return $res;
 }
 
 sub _determine_driver {
@@ -1224,9 +1246,11 @@ sub _do_query {
     my $attrs = shift @do_args;
     my @bind = map { [ undef, $_ ] } @do_args;
 
-    $self->_query_start($sql, \@bind);
-    $self->_get_dbh->do($sql, $attrs, @do_args);
-    $self->_query_end($sql, \@bind);
+    $self->dbh_do(sub {
+      $_[0]->_query_start($sql, \@bind);
+      $_[1]->do($sql, $attrs, @do_args);
+      $_[0]->_query_end($sql, \@bind);
+    });
   }
 
   return $self;
@@ -1240,10 +1264,7 @@ sub _connect {
 
   my ($old_connect_via, $dbh);
 
-  if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
-    $old_connect_via = $DBI::connect_via;
-    $DBI::connect_via = 'connect';
-  }
+  local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
 
   try {
     if(ref $info[0] eq 'CODE') {
@@ -1305,9 +1326,6 @@ sub _connect {
   }
   catch {
     $self->throw_exception("DBI Connection failed: $_")
-  }
-  finally {
-    $DBI::connect_via = $old_connect_via if $old_connect_via;
   };
 
   $self->_dbh_autocommit($dbh->{AutoCommit});
@@ -1672,10 +1690,17 @@ sub insert {
   # they can be fused once again with the final return
   $to_insert = { %$to_insert, %$prefetched_values };
 
+  # FIXME - we seem to assume undef values as non-supplied. This is wrong.
+  # Investigate what does it take to s/defined/exists/
   my $col_infos = $source->columns_info;
   my %pcols = map { $_ => 1 } $source->primary_columns;
-  my %retrieve_cols;
+  my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col);
   for my $col ($source->columns) {
+    if ($col_infos->{$col}{is_auto_increment}) {
+      $autoinc_supplied ||= 1 if defined $to_insert->{$col};
+      $retrieve_autoinc_col ||= $col unless $autoinc_supplied;
+    }
+
     # nothing to retrieve when explicit values are supplied
     next if (defined $to_insert->{$col} and ! (
       ref $to_insert->{$col} eq 'SCALAR'
@@ -1691,6 +1716,9 @@ sub insert {
     );
   };
 
+  local $self->{_autoinc_supplied_for_op} = $autoinc_supplied;
+  local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col;
+
   my ($sqla_opts, @ir_container);
   if (%retrieve_cols and $self->_use_insert_returning) {
     $sqla_opts->{returning_container} = \@ir_container
@@ -1769,7 +1797,13 @@ sub insert_bulk {
     }
   }
 
-  my $colinfo_cache = {}; # since we will run _resolve_bindattrs on the same $source a lot
+  my $colinfos = $source->columns_info($cols);
+
+  local $self->{_autoinc_supplied_for_op} =
+    (first { $_->{is_auto_increment} } values %$colinfos)
+      ? 1
+      : 0
+  ;
 
   # get a slice type index based on first row of data
   # a "column" in this context may refer to more than one bind value
@@ -1806,7 +1840,7 @@ sub insert_bulk {
 
       # normalization of user supplied stuff
       my $resolved_bind = $self->_resolve_bindattrs(
-        $source, \@bind, $colinfo_cache,
+        $source, \@bind, $colinfos,
       );
 
       # store value-less (attrs only) bind info - we will be comparing all
@@ -1922,7 +1956,7 @@ sub insert_bulk {
               map
               { $_->[0] }
               @{$self->_resolve_bindattrs(
-                $source, [ @{$$val}[1 .. $#$$val] ], $colinfo_cache,
+                $source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
               )}
             ],
           )) {
@@ -1960,7 +1994,7 @@ sub insert_bulk {
 
   $guard->commit;
 
-  return (wantarray ? ($rv, $sth, @$proto_bind) : $rv);
+  return wantarray ? ($rv, $sth, @$proto_bind) : $rv;
 }
 
 # execute_for_fetch is capable of returning data just fine (it means it
@@ -2105,6 +2139,10 @@ sub _select {
 sub _select_args_to_query {
   my $self = shift;
 
+  $self->throw_exception(
+    "Unable to generate limited query representation with 'software_limit' enabled"
+  ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) );
+
   # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
   #  = $self->_select_args($ident, $select, $cond, $attrs);
   my ($op, $ident, @args) =
@@ -2180,7 +2218,15 @@ sub _select_args {
   }
 
   # try to simplify the joinmap further (prune unreferenced type-single joins)
-  $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+  if (
+    ref $ident
+      and
+    reftype $ident eq 'ARRAY'
+      and
+    @$ident != 1
+  ) {
+    $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+  }
 
 ###
   # This would be the point to deflate anything found in $where
@@ -2737,18 +2783,12 @@ sub deployment_statements {
     data => $schema,
   );
 
-  my @ret;
-  if (wantarray) {
-    @ret = $tr->translate;
-  }
-  else {
-    $ret[0] = $tr->translate;
-  }
-
-  $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
-    unless (@ret && defined $ret[0]);
-
-  return wantarray ? @ret : $ret[0];
+  return preserve_context {
+    $tr->translate
+  } after => sub {
+    $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+      unless defined $_[0];
+  };
 }
 
 # FIXME deploy() currently does not accurately report sql errors
@@ -2939,6 +2979,13 @@ sub _is_text_lob_type {
                         |national\s*character\s*varying))\z/xi);
 }
 
+# Determine if a data_type is some type of a binary type
+sub _is_binary_type {
+  my ($self, $data_type) = @_;
+  $data_type && ($self->_is_binary_lob_type($data_type)
+    || $data_type =~ /(?:var)?(?:binary|bit|graphic)(?:\s*varying)?/i);
+}
+
 1;
 
 =head1 USAGE NOTES