Revert part of bbcc1fe8 - the 'queue unstick hack' belongs in DBICTest

[dbsrgits/DBIx-Class.git] / t / lib / DBICTest / Util.pm

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 98f05c0..37c7916 100644 (file)
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -3,20 +3,6 @@ package DBICTest::Util;
 use warnings;
 use strict;
 
-# this noop trick initializes the STDOUT, so that the TAP::Harness
-# issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
-# keep spinning and scheduling jobs
-# This results in an overall much smoother job-queue drainage, since
-# the Harness blocks less
-# (ideally this needs to be addressed in T::H, but a quick patchjob
-# broke everything so tabling it for now)
-BEGIN {
-  if ($INC{'Test/Builder.pm'}) {
-    local $| = 1;
-    print "#\n";
-  }
-}
-
 use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
   ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
     ||
@@ -24,9 +10,10 @@ use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
 ;
 
 use Config;
-use Carp 'confess';
+use Carp qw(cluck confess croak);
+use Fcntl ':flock';
 use Scalar::Util qw(blessed refaddr);
-use DBIx::Class::_Util;
+use DBIx::Class::_Util 'scope_guard';
 
 use base 'Exporter';
 our @EXPORT_OK = qw(
@@ -34,7 +21,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,27 +44,58 @@ sub dbg ($) {
   ;
 }
 
-sub local_umask {
+# 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};
 
-  die 'Calling local_umask() in void context makes no sense'
+  croak 'Calling local_umask() in void context makes no sense'
     if ! defined wantarray;
 
-  my $old_umask = umask(shift());
+  my $old_umask = umask($_[0]);
   die "Setting umask failed: $!" unless defined $old_umask;
 
-  return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
-}
-{
-  package DBICTest::Util::UmaskGuard;
-  sub DESTROY {
-    &DBIx::Class::_Util::detected_reinvoked_destructor;
-
-    local ($@, $!);
-    eval { defined (umask ${$_[0]}) or die };
-    warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
-      if ($@ || $!);
-  }
+  scope_guard(sub {
+    local ($@, $!, $?);
+
+    eval {
+      defined(umask $old_umask) or die "nope";
+      1;
+    } or cluck (
+      "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
+    );
+  });
 }
 
 sub stacktrace {