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