X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil.pm;h=3e250ccafb4889db237886b453f6dfb8951da126;hb=501d6e066f4a0007c70749fccaac3777d645c623;hp=985e07271977ba5a42a15b83dc8bbef968edd2ad;hpb=e1d9e578b84f642cb24181d0403b15ab78a9fda7;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 985e072..3e250cc 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -3,57 +3,364 @@ 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 ANFANG; use Config; -use Carp 'confess'; -use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util; +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 { + + DEBUG_TEST_CONCURRENCY_LOCKS => ( + ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] + || + 0 + ), + + # During 5.13 dev cycle HELEMs started to leak on copy + # 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 + ), +}; use base 'Exporter'; -our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args visit_namespaces); +our @EXPORT_OK = qw( + dbg stacktrace class_seems_loaded + local_umask slurp_bytes tmpdir find_co_root rm_rf + PEEPEENESS + check_customcond_args + await_flock DEBUG_TEST_CONCURRENCY_LOCKS +); + +if (DEBUG_TEST_CONCURRENCY_LOCKS) { + require DBI; + my $oc = DBI->can('connect'); + no warnings 'redefine'; + *DBI::connect = sub { + DBICTest::Util::dbg("Connecting to $_[1]"); + goto $oc; + } +} + +sub dbg ($) { + require Time::HiRes; + printf STDERR "\n%.06f %5s %-78s %s\n", + scalar Time::HiRes::time(), + $$, + $_[0], + $0, + ; +} + +# File locking is hard. Really hard. By far the best lock implementation +# I've seen is part of the guts of File::Temp. However it is sadly not +# reusable. Since I am not aware of folks doing NFS parallel testing, +# nor are we known to work on VMS, I am just going to punt this and +# use the portable-ish flock() provided by perl itself. If this does +# not work for you - patches more than welcome. +# +# 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 = 30; # yes, that's long, I know +my $wait_step_seconds = 0.25; + +sub await_flock ($$) { + my ($fh, $locktype) = @_; + + my ($res, $tries); + while( + ! ( $res = flock( $fh, $locktype | LOCK_NB ) ) + and + ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds + ) { + select( undef, undef, undef, $wait_step_seconds ); + + # "say something" every 10 cycles to work around RT#108390 + # jesus christ our tooling is such a crock of shit :( + 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"; + } + } + + print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: " + unless $res; -sub local_umask { + return $res; +} + + +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()); - die "Setting umask failed: $!" unless defined $old_umask; + my $old_umask = umask($_[0]); + croak "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"; + } + + # at this point we are pretty sure this is the right thing - detaint + ($root =~ /(.+)/)[0]; } } +my $tempdir; +sub tmpdir () { + $tempdir ||= do { + + require File::Spec; + my $dir = File::Spec->tmpdir; + $dir .= '/' unless $dir =~ / [\/\\] $ /x; + + # the above works but not always, test it to bits + my $reason_dir_unusable; + + # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. + # This is *really* stupid and the result of having our lockfiles all over + # the place is also rather obnoxious. So we use our own heuristics instead + # https://rt.cpan.org/Ticket/Display.html?id=76663 + my @parts = File::Spec->splitdir($dir); + + # deal with how 'C:\\\\\\\\\\\\\\' decomposes + pop @parts while @parts and ! length $parts[-1]; + + if ( + @parts < 2 + or + ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) + ) { + $reason_dir_unusable = + 'File::Spec->tmpdir returned a root directory instead of a designated ' + . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; + } + else { + # make sure we can actually create and sysopen a file in this dir + + my $fn = $dir . "_dbictest_writability_test_$$"; + + my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) + my $g = scope_guard { unlink $fn }; + + eval { + + if (-e $fn) { + unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; + } + + sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; + + print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; + + close $tmpfh or die "Closing $fn failed: $!\n"; + + 1; + } + or + do { + chomp( my $err = $@ ); + + my @x_tests = map + { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } + map + { (-e, -d, -f, -r, -w, -x, -o)} + ($dir, $fn) + ; + + $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; +File::Spec->tmpdir returned a directory which appears to be non-writeable: + +Error encountered while testing '%s': %s +Process EUID/EGID: %s / %s +Effective umask: %o +TmpDir UID/GID: %s / %s +TmpDir StatMode: %o +TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +EOE + }; + } + + if ($reason_dir_unusable) { + # Replace with our local project tmpdir. This will make multiple tests + # from different runs conflict with each other, but is much better than + # polluting the root dir with random crap or failing outright + my $local_dir = find_co_root . 't/var/'; + + # 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; + } + + $dir; + }; +} + + +sub slurp_bytes ($) { + croak "Expecting a file name, not a filehandle" if openhandle $_[0]; + croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0]; + open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!"; + local $/ unless wantarray; + <$fh>; +} + + +sub rm_rf ($) { + croak "No argument supplied to rm_rf()" unless length "$_[0]"; + + return unless -e $_[0]; + +### I do not trust myself - check for subsuming ( the right way ) +### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637 + require Cwd; + + my ($target, $tmp, $co_tmp) = map { + + my $abs_fn = Cwd::abs_path("$_"); + + if ( $^O eq 'MSWin32' and length $abs_fn ) { + + # sometimes we can get a short/longname mix, normalize everything to longnames + $abs_fn = Win32::GetLongPathName($abs_fn); + + # Fixup for unixy (as opposed to native) slashes + $abs_fn =~ s|\\|/|g; + } + + $abs_fn =~ s| (?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++; my (@stack, @frame); - while (@frame = caller($frame++)) { + while (@frame = CORE::caller($frame++)) { push @stack, [@frame[3,1,2]]; } @@ -109,34 +416,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;