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