X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil.pm;fp=t%2Flib%2FDBICTest%2FUtil.pm;h=74ba0684efe495054819ec38d588dd81f669a16d;hb=630e2ea8a42ab04c12effadf75e11b5081334899;hp=98f05c00b4651314484b89d2eb71bdbaa3f1bfdf;hpb=072b62c48b130d75f4e96ecdb4c46095f520050d;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 98f05c0..74ba068 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -25,6 +25,7 @@ use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
 
 use Config;
 use Carp 'confess';
+use Fcntl ':flock';
 use Scalar::Util qw(blessed refaddr);
 use DBIx::Class::_Util;
 
@@ -34,7 +35,7 @@ our @EXPORT_OK = qw(
   local_umask
   visit_namespaces
   check_customcond_args
-  DEBUG_TEST_CONCURRENCY_LOCKS
+  await_flock DEBUG_TEST_CONCURRENCY_LOCKS
 );
 
 if (DEBUG_TEST_CONCURRENCY_LOCKS) {
@@ -57,6 +58,38 @@ sub dbg ($) {
   ;
 }
 
+# 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.
+#
+# This figure esentially means "how long can a single test hold a
+# resource before everyone else gives up waiting and aborts" or
+# in other words "how long does the longest test-group legitimally run?"
+my $lock_timeout_minutes = 15;  # yes, that's long, I know
+my $wait_step_seconds = 0.25;
+
+sub await_flock ($$) {
+  my ($fh, $locktype) = @_;
+
+  my ($res, $tries);
+  while(
+    ! ( $res = flock( $fh, $locktype | LOCK_NB ) )
+      and
+    ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds
+  ) {
+    select( undef, undef, undef, $wait_step_seconds );
+
+    # "say something" every 10 cycles to work around RT#108390
+    # jesus christ our tooling is such a crock of shit :(
+    print "#\n" if not $tries % 10;
+  }
+
+  return $res;
+}
+
 sub local_umask {
   return unless defined $Config{d_umask};