X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil.pm;h=990050cb0306c81f533a6c539e1f0c077baba456;hb=17afd4efaada78208fcb697599292a284a825cdb;hp=5d54c11703ca1ae7cf8f8552ffd281087748e8bf;hpb=e48635f7178f8527ec3cc230f1cf869e8876dc39;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 5d54c11..990050c 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -31,11 +31,11 @@ use Config;
 use Carp qw(cluck confess croak);
 use Fcntl qw( :DEFAULT :flock );
 use Scalar::Util qw( blessed refaddr openhandle );
-use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p );
+use DBIx::Class::_Util qw( scope_guard parent_dir );
 
 use base 'Exporter';
 our @EXPORT_OK = qw(
-  dbg stacktrace
+  dbg stacktrace class_seems_loaded
   local_umask slurp_bytes tmpdir find_co_root rm_rf
   visit_namespaces PEEPEENESS
   check_customcond_args
@@ -88,7 +88,21 @@ sub await_flock ($$) {
 
     # "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;
+    unless ( $tries % 10 ) {
+
+      # Turning on autoflush is crucial: if stars align just right buffering
+      # will ensure we never actually call write() underneath until the grand
+      # timeout is reached (and that's too long). Reproducible via
+      #
+      # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \
+      # DBICTEST_RUN_ALL_TESTS=1 \
+      # strace -f \
+      # prove -lj10 xt/extra/internals/
+      #
+      select( ( select(\*STDOUT), $|=1 )[0] );
+
+      print "#\n";
+    }
   }
 
   return $res;
@@ -235,7 +249,15 @@ EOE
       # polluting the root dir with random crap or failing outright
       my $local_dir = find_co_root . 't/var/';
 
-      mkdir_p $local_dir;
+      # Generlly this should be handled by ANFANG, but double-check ourselves
+      # Not using mkdir_p here: we *know* everything else up until 'var' exists
+      # If it doesn't - we better fail outright
+      # (also saves an extra File::Path require(), small enough as it is)
+      -d $local_dir
+        or
+      mkdir $local_dir
+        or
+      die "Unable to create build-local tempdir '$local_dir': $!\n";
 
       warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n";
       $dir = $local_dir;
@@ -302,6 +324,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++;
@@ -393,4 +439,27 @@ sub visit_namespaces {
   return $visited_count;
 }
 
+#
+# Replicate the *heuristic* (important!!!) implementation found in various
+# forms within Class::Load / Module::Inspector / Class::C3::Componentised
+#
+sub class_seems_loaded ($) {
+
+  croak "Function expects a class name as plain string (no references)"
+    unless defined $_[0] and not length ref $_[0];
+
+  no strict 'refs';
+
+  return 1 if defined ${"$_[0]::VERSION"};
+
+  return 1 if @{"$_[0]::ISA"};
+
+  return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' };
+
+  ( !!*{"$_[0]::$_"}{CODE} ) and return 1
+    for keys %{"$_[0]::"};
+
+  return 0;
+}
+
 1;