-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 = '<NONCREATABLE>';
+ 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:
if (@fail_reasons) {
print STDERR <<'EOE';
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
======================== FATAL ERROR ===========================
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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
}
print STDERR "\n\n\n";
+ require Time::HiRes;
+ Time::HiRes::sleep(0.005);
+ print STDOUT "\nBail out!\n";
exit 1;
}
}
}
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;
projects / dbsrgits/DBIx-Class.git / blobdiff