X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FRunMode.pm;h=590abde0e3059a703994845c9f092db9542c039e;hb=e3be2b6ff05d6794ccd8807af8cb494403690639;hp=d96fdcde980ec55a2fe28ef433d3d46d579f7e75;hpb=d5e5fb4b47b759b202e552ff1d2f1dd393ac7b39;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index d96fdcd..590abde 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -1,13 +1,146 @@ -package # hide from PAUSE +package # hide from PAUSE DBICTest::RunMode; use strict; use warnings; +BEGIN { + if ($INC{'DBIx/Class.pm'}) { + my ($fr, @frame) = 1; + while (@frame = caller($fr++)) { + last if $frame[1] !~ m|^t/lib/DBICTest|; + } + + die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n"; + } + + if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { + my $ov = UNIVERSAL->can("VERSION"); + + require Carp; + + no warnings 'redefine'; + *UNIVERSAL::VERSION = sub { + Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); + &$ov; + }; + } + + if ( + $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} + or + # keep it always on during CI + ( + ($ENV{TRAVIS}||'') eq 'true' + and + ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| + ) + ) { + require Try::Tiny; + my $orig = \&Try::Tiny::try; + + no warnings 'redefine'; + *Try::Tiny::try = sub (&;@) { + my ($fr, $first_pkg) = 0; + while( $first_pkg = caller($fr++) ) { + last if $first_pkg !~ /^ + __ANON__ + | + \Q(eval)\E + $/x; + } + + if ($first_pkg =~ /DBIx::Class/) { + require Test::Builder; + Test::Builder->new->ok(0, + 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' + ); + } + + goto $orig; + }; + } +} + use Path::Class qw/file dir/; +use Fcntl ':DEFAULT'; +use File::Spec (); +use File::Temp (); +use DBICTest::Util qw( local_umask find_co_root ); + +# Try to determine the root of a checkout/untar if possible +# return a Path::Class::Dir object or undef +sub _find_co_root { eval { dir( find_co_root() ) } } _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; +# 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 $tmpdir; +sub tmpdir { + dir ($tmpdir ||= do { + + # works but not always + my $dir = dir(File::Spec->tmpdir); + my $reason_dir_unusable; + + my @parts = File::Spec->splitdir($dir); + if (@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 + local $@; + my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) + my $tempfile = ''; + eval { + $tempfile = File::Temp->new( + TEMPLATE => '_dbictest_writability_test_XXXXXX', + DIR => "$dir", + UNLINK => 1, + ); + close $tempfile or die "closing $tempfile failed: $!\n"; + + sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; + print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; + close $tempfh2 or die "closing $tempfile 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", "$tempfile"); + $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $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 runs + # 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()->subdir('t')->subdir('var'); + $local_dir->mkpath; + + warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; + $dir = $local_dir; + } + + $dir->stringify; + }); +} + + # Die if the author did not update his makefile # # This is pretty heavy handed, so the check is pretty solid: @@ -58,7 +191,6 @@ sub _check_author_makefile { if (@fail_reasons) { print STDERR <<'EOE'; - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ======================== FATAL ERROR =========================== !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -68,9 +200,9 @@ checkout and that you, the user, did not run `perl Makefile.PL` before using this code. You absolutely _must_ perform this step, to ensure you have all required dependencies present. Not doing so often results in a lot of wasted time for other contributors -trying to assit you with spurious "its broken!" problems. +trying to assist you with spurious "its broken!" problems. -By default DBICs Makefile.PL turns all optional dependenciess into +By default DBICs Makefile.PL turns all optional dependencies into *HARD REQUIREMENTS*, in order to make sure that the entire test suite is executed, and no tests are skipped due to missing modules. If you for some reason need to disable this behavior - supply the @@ -95,28 +227,13 @@ EOE } print STDERR "\n\n\n"; + require Time::HiRes; + Time::HiRes::sleep(0.005); + print STDOUT "\nBail out!\n"; exit 1; } } -sub peepeeness { - return ! $ENV{DBICTEST_ALL_LEAKS} if defined $ENV{DBICTEST_ALL_LEAKS}; - - # don't smoke perls with known issues: - if (__PACKAGE__->is_smoker) { - if ($] == '5.013006') { - # leaky 5.13.6 (fixed in blead/cefd5c7c) - return 1; - } - elsif ($] == '5.013005') { - # not sure why this one leaks, but disable anyway - ANDK seems to make it weep - return 1; - } - } - - return 0; -} - # Mimic $Module::Install::AUTHOR sub is_author { @@ -131,35 +248,31 @@ sub is_author { } sub is_smoker { - return ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) + return ( + ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) + or + __PACKAGE__->is_ci + ); } -sub is_plain { - return (! __PACKAGE__->is_smoker && ! __PACKAGE__->is_author && ! $ENV{RELEASE_TESTING} ) +sub is_ci { + return ( + ($ENV{TRAVIS}||'') eq 'true' + and + ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| + ) } -# Try to determine the root of a checkout/untar if possible -# or return undef -sub _find_co_root { - - my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); - my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS - - return undef unless ($INC{$rel_path}); - - # 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 = dir ($INC{$rel_path}); - for (1 .. @mod_parts + 2) { - $root = $root->parent; - } - - return (-f $root->file ('Makefile.PL') ) - ? $root - : undef - ; +sub is_plain { + return ( + ! $ENV{RELEASE_TESTING} + and + ! $ENV{DBICTEST_RUN_ALL_TESTS} + and + ! __PACKAGE__->is_smoker + and + ! __PACKAGE__->is_author + ) } 1;