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