Add comprehensive concurrent-test-locking logging to aid future debugging

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 04e6b9f..6dd9562 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -21,8 +21,7 @@ BEGIN {
 
     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
 
-    # ::Runmode would only be loaded by DBICTest, which in turn implies t/
-    DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0,
+    DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0,
 
     # During 5.13 dev cycle HELEMs started to leak on copy
     # add an escape for these perls ON SMOKERS - a user will still get death

diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index 072f585..a5ac0c5 100644 (file)
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -83,6 +83,12 @@ BEGIN {
   }
 }
 
+BEGIN {
+  delete $ENV{$_} for qw(
+    DBICTEST_DEBUG_CONCURRENCY_LOCKS
+  );
+}
+
 #######
 ### This is where the test starts
 #######

diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm
index c72ed65..a958331 100644 (file)
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -4,7 +4,7 @@ package # hide from PAUSE
 use strict;
 use warnings;
 
-use DBICTest::Util 'local_umask';
+use DBICTest::Util qw( local_umask dbg DEBUG_TEST_CONCURRENCY_LOCKS );
 use DBICTest::Schema;
 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
 use DBIx::Class::_Util 'detected_reinvoked_destructor';
@@ -90,7 +90,14 @@ sub import {
 
     for my $exp (@_) {
         if ($exp eq ':GlobalLock') {
+            DEBUG_TEST_CONCURRENCY_LOCKS > 1
+              and dbg "Waiting for EXCLUSIVE global lock...";
+
             flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+
+            DEBUG_TEST_CONCURRENCY_LOCKS > 1
+              and dbg "Got EXCLUSIVE global lock";
+
             $global_exclusive_lock = 1;
         }
         elsif ($exp eq ':DiffSQL') {
@@ -107,13 +114,22 @@ sub import {
     }
 
     unless ($global_exclusive_lock) {
+        DEBUG_TEST_CONCURRENCY_LOCKS > 1
+          and dbg "Waiting for SHARED global lock...";
+
         flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
+
+        DEBUG_TEST_CONCURRENCY_LOCKS > 1
+          and dbg "Got SHARED global lock";
     }
 }
 
 END {
+    # referencing here delays destruction even more
     if ($global_lock_fh) {
-        # delay destruction even more
+      DEBUG_TEST_CONCURRENCY_LOCKS > 1
+        and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
+      1;
     }
 }
 

diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm
index 82e4dd9..92234dc 100644 (file)
--- a/t/lib/DBICTest/BaseSchema.pm
+++ b/t/lib/DBICTest/BaseSchema.pm
@@ -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 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}";
   }
 }
 
@@ -186,18 +187,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";
+
+      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 +218,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 $!";

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 985e072..f7f2032 100644 (file)
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -17,13 +17,45 @@ BEGIN {
   }
 }
 
+use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
+  ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
+    ||
+  0
+;
+
 use Config;
 use Carp 'confess';
 use Scalar::Util qw(blessed refaddr);
 use DBIx::Class::_Util;
 
 use base 'Exporter';
-our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args visit_namespaces);
+our @EXPORT_OK = qw(
+  dbg stacktrace
+  local_umask
+  visit_namespaces
+  check_customcond_args
+  DEBUG_TEST_CONCURRENCY_LOCKS
+);
+
+if (DEBUG_TEST_CONCURRENCY_LOCKS) {
+  require DBI;
+  my $oc = DBI->can('connect');
+  no warnings 'redefine';
+  *DBI::connect = sub {
+    DBICTest::Util::dbg("Connecting to $_[1]");
+    goto $oc;
+  }
+}
+
+sub dbg ($) {
+  require Time::HiRes;
+  printf STDERR "\n%.06f  %5s %-78s %s\n",
+    scalar Time::HiRes::time(),
+    $$,
+    $_[0],
+    $0,
+  ;
+}
 
 sub local_umask {
   return unless defined $Config{d_umask};