t/lib/DBICTest/RunMode.pm

   1 package # hide from PAUSE
   2     DBICTest::RunMode;
   3
   4 use strict;
   5 use warnings;
   6
   7 BEGIN {
   8   if ($INC{'DBIx/Class.pm'}) {
   9     my ($fr, @frame) = 1;
  10     while (@frame = caller($fr++)) {
  11       last if $frame[1] !~ m|^t/lib/DBICTest|;
  12     }
  13
  14     die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n";
  15   }
  16
  17   if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) {
  18     my $ov = UNIVERSAL->can("VERSION");
  19
  20     require Carp;
  21
  22     no warnings 'redefine';
  23     *UNIVERSAL::VERSION = sub {
  24       Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' );
  25       &$ov;
  26     };
  27   }
  28
  29   if (
  30     $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION}
  31       or
  32     # keep it always on during CI
  33     (
  34       ($ENV{TRAVIS}||'') eq 'true'
  35         and
  36       ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
  37     )
  38   ) {
  39     require Try::Tiny;
  40     my $orig = \&Try::Tiny::try;
  41
  42     no warnings 'redefine';
  43     *Try::Tiny::try = sub (&;@) {
  44       my ($fr, $first_pkg) = 0;
  45       while( $first_pkg = caller($fr++) ) {
  46         last if $first_pkg !~ /^
  47           __ANON__
  48             |
  49           \Q(eval)\E
  50         $/x;
  51       }
  52
  53       if ($first_pkg =~ /DBIx::Class/) {
  54         require Test::Builder;
  55         Test::Builder->new->ok(0,
  56           'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead'
  57         );
  58       }
  59
  60       goto $orig;
  61     };
  62   }
  63 }
  64
  65 use Path::Class qw/file dir/;
  66 use Fcntl ':DEFAULT';
  67 use File::Spec ();
  68 use File::Temp ();
  69 use DBICTest::Util qw( local_umask find_co_root );
  70
  71 # Try to determine the root of a checkout/untar if possible
  72 # return a Path::Class::Dir object or undef
  73 sub _find_co_root { eval { dir( find_co_root() ) } }
  74
  75 _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION};
  76
  77 # PathTools has a bug where on MSWin32 it will often return / as a tmpdir.
  78 # This is *really* stupid and the result of having our lockfiles all over
  79 # the place is also rather obnoxious. So we use our own heuristics instead
  80 # https://rt.cpan.org/Ticket/Display.html?id=76663
  81 my $tmpdir;
  82 sub tmpdir {
  83   dir ($tmpdir ||= do {
  84
  85     # works but not always
  86     my $dir = dir(File::Spec->tmpdir);
  87     my $reason_dir_unusable;
  88
  89     my @parts = File::Spec->splitdir($dir);
  90     if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) {
  91       $reason_dir_unusable =
  92         'File::Spec->tmpdir returned a root directory instead of a designated '
  93       . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)';
  94     }
  95     else {
  96       # make sure we can actually create and sysopen a file in this dir
  97       local $@;
  98       my $u = local_umask(0); # match the umask we use in DBICTest(::Schema)
  99       my $tempfile = '<NONCREATABLE>';
 100       eval {
 101         $tempfile = File::Temp->new(
 102           TEMPLATE => '_dbictest_writability_test_XXXXXX',
 103           DIR => "$dir",
 104           UNLINK => 1,
 105         );
 106         close $tempfile or die "closing $tempfile failed: $!\n";
 107
 108         sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n";
 109         print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n";
 110         close $tempfh2 or die "closing $tempfile failed: $!\n";
 111         1;
 112       } or do {
 113         chomp( my $err = $@ );
 114         my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile");
 115         $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests;
 116 File::Spec->tmpdir returned a directory which appears to be non-writeable:
 117 Error encountered while testing '%s': %s
 118 Process EUID/EGID: %s / %s
 119 Effective umask:   %o
 120 TmpDir UID/GID:    %s / %s
 121 TmpDir StatMode:   %o
 122 TmpDir X-tests:    -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 123 TmpFile X-tests:   -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 124 EOE
 125       };
 126     }
 127
 128     if ($reason_dir_unusable) {
 129       # Replace with our local project tmpdir. This will make multiple runs
 130       # from different runs conflict with each other, but is much better than
 131       # polluting the root dir with random crap or failing outright
 132       my $local_dir = _find_co_root()->subdir('t')->subdir('var');
 133       $local_dir->mkpath;
 134
 135       warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n";
 136       $dir = $local_dir;
 137     }
 138
 139     $dir->stringify;
 140   });
 141 }
 142
 143
 144 # Die if the author did not update his makefile
 145 #
 146 # This is pretty heavy handed, so the check is pretty solid:
 147 #
 148 # 1) Assume that this particular module is loaded from -I <$root>/t/lib
 149 # 2) Make sure <$root>/Makefile.PL exists
 150 # 3) Make sure we can stat() <$root>/Makefile.PL
 151 #
 152 # If all of the above is satisfied
 153 #
 154 # *) die if <$root>/inc does not exist
 155 # *) die if no stat() results for <$root>/Makefile (covers no Makefile)
 156 # *) die if Makefile.PL mtime > Makefile mtime
 157 #
 158 sub _check_author_makefile {
 159
 160   my $root = _find_co_root()
 161     or return;
 162
 163   my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm');
 164
 165   # not using file->stat as it invokes File::stat which in turn breaks stat(_)
 166   my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map
 167     { (stat ($root->file ($_)) )[9] || undef }  # stat returns () on nonexistent files
 168     (qw|Makefile.PL  Makefile|, $optdeps)
 169   );
 170
 171   return unless $mf_pl_mtime;   # something went wrong during co_root detection ?
 172
 173   my @fail_reasons;
 174
 175   if(not -d $root->subdir ('inc')) {
 176     push @fail_reasons, "Missing ./inc directory";
 177   }
 178
 179   if(not $mf_mtime) {
 180     push @fail_reasons, "Missing ./Makefile";
 181   }
 182   else {
 183     if($mf_mtime < $mf_pl_mtime) {
 184       push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
 185     }
 186     if($mf_mtime < $optdeps_mtime) {
 187       push @fail_reasons, "./$optdeps is newer than ./Makefile";
 188     }
 189   }
 190
 191   if (@fail_reasons) {
 192     print STDERR <<'EOE';
 193
 194 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 195 ======================== FATAL ERROR ===========================
 196 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 197
 198 We have a number of reasons to believe that this is a development
 199 checkout and that you, the user, did not run `perl Makefile.PL`
 200 before using this code. You absolutely _must_ perform this step,
 201 to ensure you have all required dependencies present. Not doing
 202 so often results in a lot of wasted time for other contributors
 203 trying to assist you with spurious "its broken!" problems.
 204
 205 By default DBICs Makefile.PL turns all optional dependencies into
 206 *HARD REQUIREMENTS*, in order to make sure that the entire test
 207 suite is executed, and no tests are skipped due to missing modules.
 208 If you for some reason need to disable this behavior - supply the
 209 --skip_author_deps option when running perl Makefile.PL
 210
 211 If you are seeing this message unexpectedly (i.e. you are in fact
 212 attempting a regular installation be it through CPAN or manually),
 213 please report the situation to either the mailing list or to the
 214 irc channel as described in
 215
 216 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT
 217
 218 The DBIC team
 219
 220
 221 Reasons you received this message:
 222
 223 EOE
 224
 225     foreach my $r (@fail_reasons) {
 226       print STDERR "  * $r\n";
 227     }
 228     print STDERR "\n\n\n";
 229
 230     require Time::HiRes;
 231     Time::HiRes::sleep(0.005);
 232     print STDOUT "\nBail out!\n";
 233     exit 1;
 234   }
 235 }
 236
 237 # Mimic $Module::Install::AUTHOR
 238 sub is_author {
 239
 240   my $root = _find_co_root()
 241     or return undef;
 242
 243   return (
 244     ( not -d $root->subdir ('inc') )
 245       or
 246     ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') )
 247   );
 248 }
 249
 250 sub is_smoker {
 251   return (
 252     ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} )
 253       or
 254     __PACKAGE__->is_ci
 255   );
 256 }
 257
 258 sub is_ci {
 259   return (
 260     ($ENV{TRAVIS}||'') eq 'true'
 261       and
 262     ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
 263   )
 264 }
 265
 266 sub is_plain {
 267   return (
 268     ! $ENV{RELEASE_TESTING}
 269       and
 270     ! $ENV{DBICTEST_RUN_ALL_TESTS}
 271       and
 272     ! __PACKAGE__->is_smoker
 273       and
 274     ! __PACKAGE__->is_author
 275   )
 276 }
 277
 278 1;