X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil.pm;h=e268b3b21fabcf5cf62315c2e35447e90b33ea15;hb=8aae794001ecccdb26c2bbd1b92c97bba9e65d79;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..e268b3b 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -5,7 +5,11 @@ use strict; use ANFANG; -use DBICTest::RunMode; +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 ); use constant { @@ -19,25 +23,25 @@ use constant { # add an escape for these perls ON SMOKERS - a user/CI will still get death # constname a homage to http://theoatmeal.com/comics/working_home PEEPEENESS => ( + ( + DBIx::Class::_ENV_::PERL_VERSION >= 5.013005 + and + DBIx::Class::_ENV_::PERL_VERSION <= 5.013006 + ) + and + require DBICTest::RunMode + and DBICTest::RunMode->is_smoker and ! DBICTest::RunMode->is_ci - and - ( "$]" >= 5.013005 and "$]" <= 5.013006) ), }; -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 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 + capture_stderr PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); @@ -72,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 ($$) { @@ -88,9 +92,25 @@ 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 STDOUT "#\n"; + } } + print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: " + unless $res; + return $res; } @@ -105,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"; @@ -235,7 +255,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; @@ -245,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]; @@ -256,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]; @@ -302,6 +360,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( -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 + + !!( $? == 0 ) +} + sub stacktrace { my $frame = shift; $frame++; @@ -363,34 +445,27 @@ sub check_customcond_args ($) { $args; } -sub visit_namespaces { - my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; - - my $visited_count = 1; - - # A package and a namespace are subtly different things - $args->{package} ||= 'main'; - $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; - $args->{package} =~ s/^:://; - - if ( $args->{action}->($args->{package}) ) { - my $ns = - ( ($args->{package} eq 'main') ? '' : $args->{package} ) - . - '::' - ; - - $visited_count += visit_namespaces( %$args, package => $_ ) for - grep - # this happens sometimes on %:: traversal - { $_ ne '::main' } - map - { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } - do { no strict 'refs'; keys %$ns } - ; - } +# +# 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 $visited_count; + return 0; } 1;