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=0b24b9578d04a6889e1cd9813bd4bc47c24b28a1;hpb=9ee23fb6415c37b55ec1dc506bd25ccb778bc623;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 0b24b95..590abde 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -13,10 +13,64 @@ BEGIN { 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 File::Spec; +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}; @@ -28,16 +82,58 @@ 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] eq '') { - # This means we were give the root dir (C:\ or something equally unacceptable) + 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 - $dir = _find_co_root()->subdir('t')->subdir('var'); - $dir->mkpath; + # 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; @@ -93,10 +189,8 @@ sub _check_author_makefile { } if (@fail_reasons) { - print STDOUT "\nBail out!\n"; print STDERR <<'EOE'; - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ======================== FATAL ERROR =========================== !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -106,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 @@ -133,6 +227,9 @@ EOE } print STDERR "\n\n\n"; + require Time::HiRes; + Time::HiRes::sleep(0.005); + print STDOUT "\nBail out!\n"; exit 1; } } @@ -151,39 +248,31 @@ sub is_author { } sub is_smoker { - return - ( ($ENV{TRAVIS}||'') eq 'true' ) - || + 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;