From: Peter Rabbitson Date: Thu, 8 Oct 2015 07:40:25 +0000 (+0200) Subject: Add comprehensive concurrent-test-locking logging to aid future debugging X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=69016f65df5f30e446734b8cc94c216915c9105b;p=dbsrgits%2FDBIx-Class-Historic.git 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 a10e50c..4829539 100644 --- 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/lib/DBICTest.pm b/t/lib/DBICTest.pm index 229859d..6da2f7e 100644 --- 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'; @@ -91,7 +91,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') { @@ -108,13 +115,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 1c42201..80d3fb1 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -9,7 +9,7 @@ use Fcntl qw(:DEFAULT :seek :flock); use Time::HiRes 'sleep'; use Scope::Guard (); 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 { @@ -119,7 +119,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}"; } } @@ -197,18 +198,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 @@ -219,12 +229,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 c7aa432..98f05c0 100644 --- 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};