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