FINALLY find and fix the elusive parallel test deadlock
[dbsrgits/DBIx-Class.git] / t / lib / DBICTest / BaseSchema.pm
index 82e4dd9..f24a083 100644 (file)
@@ -8,7 +8,7 @@ use base qw(DBICTest::Base DBIx::Class::Schema);
 use Fcntl qw(:DEFAULT :seek :flock);
 use Time::HiRes 'sleep';
 use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
-use DBICTest::Util 'local_umask';
+use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
 use namespace::clean;
 
 sub capture_executed_sql_bind {
@@ -108,7 +108,8 @@ our $locker;
 END {
   # we need the $locker to be referenced here for delayed destruction
   if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
-    #warn "$$ $0 $locker->{type} LOCK RELEASED";
+    DEBUG_TEST_CONCURRENCY_LOCKS
+      and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}";
   }
 }
 
@@ -139,13 +140,6 @@ sub connection {
   # an envvar, we can not detect when a user invokes prove -jN. Hence
   # perform the locking at all times, it shouldn't hurt.
   # the lock fh *should* inherit across forks/subprocesses
-  #
-  # File locking is hard. Really hard. By far the best lock implementation
-  # I've seen is part of the guts of File::Temp. However it is sadly not
-  # reusable. Since I am not aware of folks doing NFS parallel testing,
-  # nor are we known to work on VMS, I am just going to punt this and
-  # use the portable-ish flock() provided by perl itself. If this does
-  # not work for you - patches more than welcome.
   if (
     ! $DBICTest::global_exclusive_lock
       and
@@ -186,18 +180,27 @@ sub connection {
 
       # this will release whatever lock we may currently be holding
       # which is fine since the type does not match as checked above
+      DEBUG_TEST_CONCURRENCY_LOCKS
+        and $locker
+        and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}";
+
       undef $locker;
 
       my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock");
 
-      #warn "$$ $0 $locktype GRABBING LOCK";
+      DEBUG_TEST_CONCURRENCY_LOCKS
+        and dbg "Waiting for $locktype LOCK: $lockpath...";
+
       my $lock_fh;
       {
         my $u = local_umask(0); # so that the file opens as 666, and any user can lock
         sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
       }
-      flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
-      #warn "$$ $0 $locktype LOCK GRABBED";
+
+      await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+
+      DEBUG_TEST_CONCURRENCY_LOCKS
+        and dbg "Got $locktype LOCK: $lockpath";
 
       # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
       # if we do not do this we may end up trampling over some long-running END or somesuch
@@ -208,12 +211,17 @@ sub connection {
           and
         ($old_pid) = $old_pid =~ /^(\d+)$/
       ) {
+        DEBUG_TEST_CONCURRENCY_LOCKS
+          and dbg "Post-grab WAIT for $old_pid START: $lockpath";
+
         for (1..50) {
           kill (0, $old_pid) or last;
           sleep 0.1;
         }
+
+        DEBUG_TEST_CONCURRENCY_LOCKS
+          and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath";
       }
-      #warn "$$ $0 $locktype POST GRAB WAIT";
 
       truncate $lock_fh, 0;
       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";