Fix building on perls with no . in @INC

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

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index dc34406..e268b3b 100644 (file)
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -41,7 +41,7 @@ use base 'Exporter';
 our @EXPORT_OK = qw(
   dbg stacktrace class_seems_loaded
   local_umask slurp_bytes tmpdir find_co_root rm_rf
-  PEEPEENESS
+  capture_stderr PEEPEENESS
   check_customcond_args
   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
 );
@@ -76,7 +76,7 @@ sub dbg ($) {
 # 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 $lock_timeout_minutes = 30;  # yes, that's long, I know
 my $wait_step_seconds = 0.25;
 
 sub await_flock ($$) {
@@ -104,11 +104,13 @@ sub await_flock ($$) {
       # prove -lj10 xt/extra/internals/
       #
       select( ( select(\*STDOUT), $|=1 )[0] );
-
-      print "#\n";
+      print STDOUT "#\n";
     }
   }
 
+  print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: "
+    unless $res;
+
   return $res;
 }
 
@@ -123,7 +125,7 @@ sub local_umask ($) {
   croak "Setting umask failed: $!" unless defined $old_umask;
 
   scope_guard(sub {
-    local ($@, $!, $?);
+    local ( $!, $^E, $?, $@ );
 
     eval {
       defined(umask $old_umask) or die "nope";
@@ -271,6 +273,36 @@ EOE
   };
 }
 
+sub capture_stderr (&) {
+  open(my $stderr_copy, '>&', *STDERR) or croak "Unable to dup STDERR: $!";
+
+  require File::Temp;
+  my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() );
+
+  my $err_out;
+
+  {
+    my $guard = scope_guard {
+      close STDERR;
+
+      open(STDERR, '>&', $stderr_copy) or do {
+        my $msg = "\n\nPANIC!!!\nFailed restore of STDERR: $!\n";
+        print $stderr_copy $msg;
+        print STDOUT $msg;
+        die;
+      };
+
+      close $stderr_copy;
+    };
+
+    close STDERR;
+    open( STDERR, '>&', $tf );
+
+    $_[0]->();
+  }
+
+  slurp_bytes( "$tf" );
+}
 
 sub slurp_bytes ($) {
   croak "Expecting a file name, not a filehandle" if openhandle $_[0];
@@ -282,7 +314,7 @@ sub slurp_bytes ($) {
 
 
 sub rm_rf ($) {
-  croak "No valid argument supplied to rm_rf()" unless length "$_[0]";
+  croak "No argument supplied to rm_rf()" unless length "$_[0]";
 
   return unless -e $_[0];
 
@@ -344,7 +376,7 @@ sub can_alloc_MB ($) {
 
   local ( $!, $^E, $?, $@ );
 
-  system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg );
+  system( $perl, qw( -It/lib -MANFANG -e ), <<'EOS', $arg );
 $0 = 'malloc_canary';
 my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 );
 EOS