From: Brandon L. Black <blblack@gmail.com>
Date: Wed, 15 Mar 2006 04:50:25 +0000 (+0000)
Subject: fork tests/code improved, ithreads tests/code added, version bumped
X-Git-Tag: v0.06000~60^2~17
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1346e22d4899edf837c77312259c3ebaaf71f602;p=dbsrgits%2FDBIx-Class.git

fork tests/code improved, ithreads tests/code added, version bumped
---

diff --git a/Changes b/Changes
index 7e7d7d9..3f32bd0 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,5 @@
 Revision history for DBIx::Class
+        - ithreads compat added, fork compat improved
         - weaken result_source in all resultsets
 
 0.05999_03 2006-03-14 01:58:10
diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index 014d87e..45ec142 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -13,7 +13,7 @@ sub component_base_class { 'DBIx::Class' }
 # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
 # brain damage and presumably various other packaging systems too
 
-$VERSION = '0.05999_03';
+$VERSION = '0.05999_04';
 
 sub MODIFY_CODE_ATTRIBUTES {
     my ($class,$code,@attrs) = @_;
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index f780d55..4ee25cc 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -210,8 +210,8 @@ use base qw/DBIx::Class/;
 __PACKAGE__->load_components(qw/AccessorGroup/);
 
 __PACKAGE__->mk_group_accessors('simple' =>
-  qw/connect_info _dbh _sql_maker _connection_pid debug debugfh cursor
-     on_connect_do transaction_depth/);
+  qw/connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
+     cursor on_connect_do transaction_depth/);
 
 sub new {
   my $new = bless({}, ref $_[0] || $_[0]);
@@ -290,8 +290,20 @@ sub disconnect {
 sub connected {
   my ($self) = @_;
 
-  my $dbh;
-  (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping)
+  if(my $dbh = $self->_dbh) {
+      if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
+          $self->_sql_maker(undef);
+          return $self->_dbh(undef);
+      }
+      elsif($self->_conn_pid != $$) {
+          $self->_dbh->{InactiveDestroy} = 1;
+          $self->_sql_maker(undef);
+          return $self->_dbh(undef)
+      }
+      return ($dbh->FETCH('Active') && $dbh->ping);
+  }
+
+  return 0;
 }
 
 sub ensure_connected {
@@ -305,10 +317,6 @@ sub ensure_connected {
 sub dbh {
   my ($self) = @_;
 
-  if($self->_connection_pid && $self->_connection_pid != $$) {
-      $self->_dbh->{InactiveDestroy} = 1;
-      $self->_dbh(undef)
-  }
   $self->ensure_connected;
   return $self->_dbh;
 }
@@ -335,7 +343,8 @@ sub _populate_dbh {
     $self->_dbh->do($sql_statement);
   }
 
-  $self->_connection_pid($$);
+  $self->_conn_pid($$);
+  $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
 }
 
 sub _connect {
@@ -412,7 +421,7 @@ sub txn_rollback {
     else {
       --$self->{transaction_depth} == 0 ?
         $self->dbh->rollback :
-	die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
+        die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
     }
   };
 
@@ -560,7 +569,7 @@ sub deploy {
   my ($self, $schema, $type, $sqltargs) = @_;
   foreach(split(";\n", $self->deployment_statements($schema, $type, $sqltargs))) {
       $self->debugfh->print("$_\n") if $self->debug;
-	  $self->dbh->do($_) or warn "SQL was:\n $_";
+          $self->dbh->do($_) or warn "SQL was:\n $_";
   } 
 }
 
diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm
index cd1926e..5334589 100644
--- a/lib/DBIx/Class/Storage/DBI/Cursor.pm
+++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm
@@ -14,12 +14,19 @@ sub new {
     storage => $storage,
     args => $args,
     pos => 0,
-    attrs => $attrs };
+    attrs => $attrs,
+    pid => $$,
+  };
+
+  $new->{tid} = threads->tid if $INC{'threads.pm'};
+  
   return bless ($new, $class);
 }
 
 sub next {
   my ($self) = @_;
+
+  $self->_check_forks_threads;
   if ($self->{attrs}{rows} && $self->{pos} >= $self->{attrs}{rows}) {
     $self->{sth}->finish if $self->{sth}->{Active};
     delete $self->{sth};
@@ -46,6 +53,8 @@ sub next {
 
 sub all {
   my ($self) = @_;
+
+  $self->_check_forks_threads;
   return $self->SUPER::all if $self->{attrs}{rows};
   $self->{sth}->finish if $self->{sth}->{Active};
   delete $self->{sth};
@@ -55,15 +64,39 @@ sub all {
 
 sub reset {
   my ($self) = @_;
+
+  $self->_check_forks_threads;
   $self->{sth}->finish if $self->{sth}->{Active};
+  $self->_soft_reset;
+}
+
+sub _soft_reset {
+  my ($self) = @_;
+
   delete $self->{sth};
   $self->{pos} = 0;
   delete $self->{done};
   return $self;
 }
 
+sub _check_forks_threads {
+  my ($self) = @_;
+
+  if($INC{'threads.pm'} && $self->{tid} != threads->tid) {
+      $self->_soft_reset;
+      $self->{tid} = threads->tid;
+  }
+
+  if($self->{pid} != $$) {
+      $self->_soft_reset;
+      $self->{pid} = $$;
+  }
+}
+
 sub DESTROY {
   my ($self) = @_;
+
+  $self->_check_forks_threads;
   $self->{sth}->finish if $self->{sth}->{Active};
 }
 
diff --git a/t/50fork.t b/t/50fork.t
index 79ba7a6..d42c0f4 100644
--- a/t/50fork.t
+++ b/t/50fork.t
@@ -1,47 +1,50 @@
-use Class::C3;
 use strict;
-use Test::More;
 use warnings;
+use Test::More;
 
-# This test passes no matter what in most cases.  However, prior to the recent
-# fork-related fixes, it would spew lots of warnings.  I have not quite gotten
-# it to where it actually fails in those cases.
+# README: If you set the env var to a number greater than 10,
+#   we will use that many children
 
 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+my $num_children = $ENV{DBICTEST_FORK_STRESS};
 
 plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test'
-    unless $ENV{DBICTEST_FORK_STRESS};
+    unless $num_children;
 
 plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
       . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
 
-plan tests => 15;
+if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
+   $num_children = 10;
+}
+
+plan tests => $num_children + 5;
 
 use lib qw(t/lib);
 
 use_ok('DBICTest::Schema');
 
-DBICTest::Schema->compose_connection('PgTest' => $dsn, $user, $pass, { AutoCommit => 1 });
+my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1 });
 
-my ($first_rs, $joe_record);
+my $parent_rs;
 
 eval {
-    my $dbh = PgTest->schema->storage->dbh;
+    my $dbh = $schema->storage->dbh;
 
-    eval {
-        $dbh->do("DROP TABLE cd");
+    {
+        local $SIG{__WARN__} = sub {};
+        eval { $dbh->do("DROP TABLE cd") };
         $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
-    };
+    }
 
-    PgTest->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
-    PgTest->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
+    $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
+    $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
 
-    $first_rs = PgTest->resultset('CD')->search({ year => 1901 });
-    $joe_record = $first_rs->next;
+    $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
+    $parent_rs->next;
 };
 ok(!$@) or diag "Creation eval failed: $@";
 
-my $num_children = 10;
 my @pids;
 while(@pids < $num_children) {
 
@@ -51,16 +54,15 @@ while(@pids < $num_children) {
     }
     elsif($pid) {
         push(@pids, $pid);
-	next;
+        next;
     }
 
     $pid = $$;
-    my ($forked_rs, $joe_forked);
 
-    $forked_rs = PgTest->resultset('CD')->search({ year => 1901 });
-    $joe_forked = $first_rs->next;
-    if($joe_forked && $joe_forked->get_column('artist') =~ /^(?:123|456)$/) {
-        PgTest->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
+    my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
+    my $row = $parent_rs->next;
+    if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
+        $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
     }
     sleep(3);
     exit;
@@ -74,10 +76,10 @@ ok(1, "past waiting");
 
 while(@pids) {
     my $pid = pop(@pids);
-    my $rs = PgTest->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
+    my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
     is($rs->next->get_column('artist'), $pid, "Child $pid successful");
 }
 
 ok(1, "Made it to the end");
 
-PgTest->schema->storage->dbh->do("DROP TABLE cd");
+$schema->storage->dbh->do("DROP TABLE cd");
diff --git a/t/51threads.t b/t/51threads.t
new file mode 100644
index 0000000..615fb09
--- /dev/null
+++ b/t/51threads.t
@@ -0,0 +1,93 @@
+use strict;
+use warnings;
+use Test::More;
+use Config;
+
+# README: If you set the env var to a number greater than 10,
+#   we will use that many children
+
+BEGIN {
+    plan skip_all => 'Your perl does not support ithreads'
+        if !$Config{useithreads} || $] < 5.008;
+}
+
+use threads;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+my $num_children = $ENV{DBICTEST_THREAD_STRESS};
+
+plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
+    unless $num_children;
+
+plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
+      . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
+
+diag 'It is normal to see a series of "Scalars leaked: ..." messages during this test';
+
+if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
+   $num_children = 10;
+}
+
+plan tests => $num_children + 5;
+
+use lib qw(t/lib);
+
+use_ok('DBICTest::Schema');
+
+my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
+
+my $parent_rs;
+
+eval {
+    my $dbh = $schema->storage->dbh;
+
+    {
+        local $SIG{__WARN__} = sub {};
+        eval { $dbh->do("DROP TABLE cd") };
+        $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
+    }
+
+    $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
+    $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
+
+    $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
+    $parent_rs->next;
+};
+ok(!$@) or diag "Creation eval failed: $@";
+
+my @children;
+while(@children < $num_children) {
+
+    my $newthread = async {
+        my $tid = threads->tid;
+        my $dbh = $schema->storage->dbh;
+
+        my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
+        my $row = $parent_rs->next;
+        if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
+            $schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) });
+        }
+        sleep(3);
+    };
+    die "Thread creation failed: $! $@" if !defined $newthread;
+    push(@children, $newthread);
+}
+
+ok(1, "past spawning");
+
+{
+    $_->join for(@children);
+}
+
+ok(1, "past joining");
+
+while(@children) {
+    my $child = pop(@children);
+    my $tid = $child->tid;
+    my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) });
+    is($rs->next->get_column('artist'), $tid, "Child $tid successful");
+}
+
+ok(1, "Made it to the end");
+
+$schema->storage->dbh->do("DROP TABLE cd");