t/lib/DBICTest/RunMode.pm

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