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