Overhaul thread handling

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index c7f0ec8..8595c16 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -11,6 +11,7 @@ use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
 use DBI;
 use DBIx::Class::Storage::DBI::Cursor;
 use Scalar::Util qw/refaddr weaken reftype blessed/;
+use List::Util qw/first/;
 use Data::Dumper::Concise 'Dumper';
 use Sub::Name 'subname';
 use Try::Tiny;
@@ -26,7 +27,7 @@ __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
 
 __PACKAGE__->mk_group_accessors('simple' => qw/
   _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
-  _dbh _dbh_details _conn_pid _conn_tid _sql_maker _sql_maker_opts
+  _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts
   transaction_depth _dbh_autocommit  savepoints
 /);
 
@@ -165,6 +166,8 @@ sub new {
 # of a fork()ed child to kill the parent's shared DBI handle,
 # *before perl reaches the DESTROY in this package*
 # Yes, it is ugly and effective.
+# Additionally this registry is used by the CLONE method to
+# make sure no handles are shared between threads
 {
   my %seek_and_destroy;
 
@@ -179,11 +182,22 @@ sub new {
     local $?; # just in case the DBI destructor changes it somehow
 
     # destroy just the object if not native to this process/thread
-    $_->_preserve_foreign_dbh for (grep
+    $_->_verify_pid for (grep
       { defined $_ }
       values %seek_and_destroy
     );
   }
+
+  sub CLONE {
+    # As per DBI's recommendation, DBIC disconnects all handles as
+    # soon as possible (DBIC will reconnect only on demand from within
+    # the thread)
+    for (values %seek_and_destroy) {
+      next unless $_;
+      $_->{_dbh_gen}++;  # so that existing cursors will drop as well
+      $_->_dbh(undef);
+    }
+  }
 }
 
 sub DESTROY {
@@ -194,51 +208,20 @@ sub DESTROY {
   $self->_dbh(undef);
 }
 
-sub _preserve_foreign_dbh {
-  my $self = shift;
-
-  return unless $self->_dbh;
-
-  $self->_verify_tid;
-
-  return unless $self->_dbh;
-
-  $self->_verify_pid;
-
-}
-
 # handle pid changes correctly - do not destroy parent's connection
 sub _verify_pid {
   my $self = shift;
 
-  return if ( defined $self->_conn_pid and $self->_conn_pid == $$ );
-
-  $self->_dbh->{InactiveDestroy} = 1;
-  $self->_dbh(undef);
-  $self->{_dbh_gen}++;
-
-  return;
-}
-
-# very similar to above, but seems to FAIL if I set InactiveDestroy
-sub _verify_tid {
-  my $self = shift;
-
-  if ( ! defined $self->_conn_tid ) {
-    return; # no threads
-  }
-  elsif ( $self->_conn_tid == threads->tid ) {
-    return; # same thread
+  my $pid = $self->_conn_pid;
+  if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) {
+    $dbh->{InactiveDestroy} = 1;
+    $self->{_dbh_gen}++;
+    $self->_dbh(undef);
   }
 
-  #$self->_dbh->{InactiveDestroy} = 1;  # why does t/51threads.t fail...?
-  $self->_dbh(undef);
-  $self->{_dbh_gen}++;
-
   return;
 }
 
-
 =head2 connect_info
 
 This method is normally called by L<DBIx::Class::Schema/connection>, which
@@ -920,7 +903,7 @@ sub connected {
 sub _seems_connected {
   my $self = shift;
 
-  $self->_preserve_foreign_dbh;
+  $self->_verify_pid;
 
   my $dbh = $self->_dbh
     or return 0;
@@ -968,7 +951,7 @@ sub dbh {
 # this is the internal "get dbh or connect (don't check)" method
 sub _get_dbh {
   my $self = shift;
-  $self->_preserve_foreign_dbh;
+  $self->_verify_pid;
   $self->_populate_dbh unless $self->_dbh;
   return $self->_dbh;
 }
@@ -1022,8 +1005,7 @@ sub _populate_dbh {
 
   $self->_dbh($self->_connect(@info));
 
-  $self->_conn_pid($$);
-  $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
+  $self->_conn_pid($$) if $^O ne 'MSWin32'; # on win32 these are in fact threads
 
   $self->_determine_driver;
 
@@ -1727,15 +1709,15 @@ sub insert_bulk {
   my ($sql, $bind) = $self->_prep_for_execute (
     'insert', undef, $source, [\%colvalues]
   );
-  my @bind = @$bind;
 
-  my $empty_bind = 1 if (not @bind) &&
-    (grep { ref $_ eq 'SCALAR' } values %colvalues) == @$cols;
+  if (! @$bind) {
+    # if the bindlist is empty - make sure all "values" are in fact
+    # literal scalarrefs. If not the case this means the storage ate
+    # them away (e.g. the NoBindVars component) and interpolated them
+    # directly into the SQL. This obviosly can't be good for multi-inserts
 
-  if ((not @bind) && (not $empty_bind)) {
-    $self->throw_exception(
-      'Cannot insert_bulk without support for placeholders'
-    );
+    $self->throw_exception('Cannot insert_bulk without support for placeholders')
+      if first { ref $_ ne 'SCALAR' } values %colvalues;
   }
 
   # neither _execute_array, nor _execute_inserts_with_no_binds are
@@ -1743,24 +1725,24 @@ sub insert_bulk {
   # scope guard
   my $guard = $self->txn_scope_guard;
 
-  $self->_query_start( $sql, [ dummy => '__BULK_INSERT__' ] );
+  $self->_query_start( $sql, @$bind ? [ dummy => '__BULK_INSERT__' ] : () );
   my $sth = $self->sth($sql);
   my $rv = do {
-    if ($empty_bind) {
-      # bind_param_array doesn't work if there are no binds
-      $self->_dbh_execute_inserts_with_no_binds( $sth, scalar @$data );
+    if (@$bind) {
+      #@bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+      $self->_execute_array( $source, $sth, $bind, $cols, $data );
     }
     else {
-#      @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
-      $self->_execute_array( $source, $sth, \@bind, $cols, $data );
+      # bind_param_array doesn't work if there are no binds
+      $self->_dbh_execute_inserts_with_no_binds( $sth, scalar @$data );
     }
   };
 
-  $self->_query_end( $sql, [ dummy => '__BULK_INSERT__' ] );
+  $self->_query_end( $sql, @$bind ? [ dummy => '__BULK_INSERT__' ] : () );
 
   $guard->commit;
 
-  return (wantarray ? ($rv, $sth, @bind) : $rv);
+  return (wantarray ? ($rv, $sth, @$bind) : $rv);
 }
 
 sub _execute_array {