From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 3 Mar 2016 14:27:34 +0000 (+0100)
Subject: Move expensive test to xt/, add malloc-canary preventing false-negatives
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=24fbd7fba01adfc25b53614f8d713af1bd31ae21

Move expensive test to xt/, add malloc-canary preventing false-negatives

This test was originally written to validate both Devel::GlobalDestruction::PP
and the M.A.D. cyclic reference handler (a4367b26). These days it makes little
sense to run on end-user installs, yet this bizarre test still uncovers weird
problems in the underlying Rube Goldberg machine.

So instead of outright deleting it - move it to xt/ and validate its execution
environment with what is essentially a guarded calloc()

Add a tight-memory travis config to make sure that OOM won't kill the wrong
thing

Read diff under -C
---

diff --git a/.travis.yml b/.travis.yml
index 4b3fb43..250679e 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -139,6 +139,7 @@ matrix:
     - perl: "5.8.8_thr"
       sudo: required
       dist: precise
+      group: legacy
       env:
         - VCPU_USE=1
         - CLEANTEST=false
diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 5d54c11..68b6e2c 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -302,6 +302,30 @@ sub rm_rf ($) {
 }
 
 
+# This is an absolutely horrible thing to do on an end-user system
+# DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker
+# Not added to EXPORT_OK on purpose
+sub can_alloc_MB ($) {
+  my $arg = shift;
+  $arg = 'UNDEF' if not defined $arg;
+
+  croak "Expecting a positive integer, got '$arg'"
+    if $arg !~ /^[1-9][0-9]*$/;
+
+  my ($perl) = $^X =~ /(.+)/;
+  local $ENV{PATH};
+  local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+
+  local ( $!, $^E, $?, $@ );
+
+  system( $perl, qw( -Mt::lib::ANFANG -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
+
+  !!( $? == 0 )
+}
+
 sub stacktrace {
   my $frame = shift;
   $frame++;
diff --git a/t/51threadnodb.t b/xt/extra/internals/ithread_stress.t
similarity index 59%
rename from t/51threadnodb.t
rename to xt/extra/internals/ithread_stress.t
index ab3683c..c1d46f2 100644
--- a/t/51threadnodb.t
+++ b/xt/extra/internals/ithread_stress.t
@@ -1,34 +1,60 @@
 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
 
+use warnings;
+use strict;
+
 use Config;
 BEGIN {
-  unless ($Config{useithreads}) {
-    print "1..0 # SKIP your perl does not support ithreads\n";
-    exit 0;
+  my $skipall;
+
+  # FIXME: this discrepancy is crazy, need to investigate
+  my $mem_needed = ($Config{ptrsize} == 4)
+    ? 200
+    : 750
+  ;
+
+  if( ! $Config{useithreads} ) {
+    $skipall = 'your perl does not support ithreads';
+  }
+  elsif( "$]" < 5.008005 ) {
+    $skipall = 'DBIC does not actively support threads before perl 5.8.5';
+  }
+  elsif( $INC{'Devel/Cover.pm'} ) {
+    $skipall = 'Devel::Cover does not work with ithreads yet';
+  }
+  elsif(
+    ! $ENV{DBICTEST_RUN_ALL_TESTS}
+      and
+    require DBICTest::RunMode
+      and
+    ! DBICTest::RunMode->is_smoker
+  ) {
+    $skipall = "Test is too expensive (may use up to ${mem_needed}MB of memory), skipping on non-smoker";
   }
+  else {
+    require threads;
+    threads->import();
 
-  if ($INC{'Devel/Cover.pm'}) {
-    print "1..0 # SKIP Devel::Cover does not work with threads yet\n";
+    require DBICTest;
+    # without this the can_alloc may very well shoot half of the CI down
+    DBICTest->import(':GlobalLock');
+
+    unless ( DBICTest::Util::can_alloc_MB($mem_needed) ) {
+      $skipall = "Your system does not have the necessary amount of memory (${mem_needed}MB) for this ridiculous test";
+    }
+  }
+
+  if( $skipall ) {
+    print "1..0 # SKIP $skipall\n";
     exit 0;
   }
 }
-use threads;
 
-use strict;
-use warnings;
 use Test::More;
 use Errno ();
 use DBIx::Class::_Util 'sigwarn_silencer';
 use Time::HiRes qw(time sleep);
 
-use DBICTest;
-
-plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
-  if "$]" < 5.008005;
-
-plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending'
-  if $^O eq 'MSWin32' && "$]" < 5.014 && DBICTest::RunMode->is_plain;
-
 # README: If you set the env var to a number greater than 5,
 #   we will use that many children
 my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
@@ -73,6 +99,7 @@ SKIP: {
 ok(1, "past spawning");
 
 $_->join for @threads;
+
 ok(1, "past joining");
 
 # Too many threading bugs on exit, none of which have anything to do with