Move find_co_root into DBICTest::Util

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

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 74ba068..27f7527 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,15 +10,15 @@ 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 qw( scope_guard parent_dir );
 
 use base 'Exporter';
 our @EXPORT_OK = qw(
   dbg stacktrace
-  local_umask
+  local_umask find_co_root
   visit_namespaces
   check_customcond_args
   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
@@ -90,29 +76,65 @@ sub await_flock ($$) {
   return $res;
 }
 
-sub local_umask {
+
+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';
+  scope_guard(sub {
+    local ($@, $!, $?);
+
+    eval {
+      defined(umask $old_umask) or die "nope";
+      1;
+    } or cluck (
+      "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
+    );
+  });
 }
-{
-  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 ($@ || $!);
+
+# Try to determine the root of a checkout/untar if possible
+# OR throws an exception
+my $co_root;
+sub find_co_root () {
+
+  $co_root ||= do {
+
+    my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
+    my $inc_key = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
+
+    # a bit convoluted, but what we do here essentially is:
+    #  - get the file name of this particular module
+    #  - do 'cd ..' as many times as necessary to get to t/lib/../..
+
+    my $root = $INC{$inc_key}
+      or croak "\$INC{'$inc_key'} seems to be missing, this can't happen...";
+
+    $root = parent_dir $root
+      for 1 .. @mod_parts + 2;
+
+    # do the check twice so that the exception is more informative in the
+    # very unlikely case of realpath returning garbage
+    # (Paththools are in really bad shape - handholding all the way down)
+    for my $call_realpath (0,1) {
+
+      require Cwd and $root = ( Cwd::realpath($root) . '/' )
+        if $call_realpath;
+
+      croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist"
+        unless -f "${root}Makefile.PL";
+    }
+
+    $root;
   }
 }
 
+
 sub stacktrace {
   my $frame = shift;
   $frame++;