Commit | Line | Data |
4bea1fe7 |
1 | package # hide from PAUSE |
39c9c72d |
2 | DBICTest::RunMode; |
ab340f7f |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
4bea1fe7 |
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 | } |
da9346a0 |
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 | } |
ddcc02d1 |
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 | } |
4bea1fe7 |
63 | } |
64 | |
ab340f7f |
65 | use Path::Class qw/file dir/; |
fa19e5d6 |
66 | use Fcntl ':DEFAULT'; |
67 | use File::Spec (); |
68 | use File::Temp (); |
0a03f539 |
69 | use DBICTest::Util 'local_umask'; |
ab340f7f |
70 | |
71 | _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; |
72 | |
9b871b00 |
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 { |
85143769 |
79 | dir ($tmpdir ||= do { |
9b871b00 |
80 | |
fa19e5d6 |
81 | # works but not always |
9b871b00 |
82 | my $dir = dir(File::Spec->tmpdir); |
fa19e5d6 |
83 | my $reason_dir_unusable; |
9b871b00 |
84 | |
85 | my @parts = File::Spec->splitdir($dir); |
6bbdf31d |
86 | if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) { |
fa19e5d6 |
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 $@; |
0a03f539 |
94 | my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) |
3ba92e4a |
95 | my $tempfile = '<NONCREATABLE>'; |
fa19e5d6 |
96 | eval { |
3ba92e4a |
97 | $tempfile = File::Temp->new( |
98 | TEMPLATE => '_dbictest_writability_test_XXXXXX', |
fa19e5d6 |
99 | DIR => "$dir", |
100 | UNLINK => 1, |
101 | ); |
3ba92e4a |
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"; |
fa19e5d6 |
107 | 1; |
108 | } or do { |
109 | chomp( my $err = $@ ); |
3ba92e4a |
110 | my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); |
0a03f539 |
111 | $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; |
fa19e5d6 |
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 |
0a03f539 |
115 | Effective umask: %o |
fa19e5d6 |
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) { |
9b871b00 |
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 |
fa19e5d6 |
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; |
9b871b00 |
133 | } |
134 | |
85143769 |
135 | $dir->stringify; |
136 | }); |
9b871b00 |
137 | } |
138 | |
139 | |
ab340f7f |
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 | |
7159a456 |
159 | my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm'); |
160 | |
ab340f7f |
161 | # not using file->stat as it invokes File::stat which in turn breaks stat(_) |
7159a456 |
162 | my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map |
50360f3e |
163 | { (stat ($root->file ($_)) )[9] || undef } # stat returns () on nonexistent files |
7159a456 |
164 | (qw|Makefile.PL Makefile|, $optdeps) |
ab340f7f |
165 | ); |
166 | |
167 | return unless $mf_pl_mtime; # something went wrong during co_root detection ? |
168 | |
7159a456 |
169 | my @fail_reasons; |
ab340f7f |
170 | |
7159a456 |
171 | if(not -d $root->subdir ('inc')) { |
172 | push @fail_reasons, "Missing ./inc directory"; |
173 | } |
ab340f7f |
174 | |
a256e995 |
175 | if(not $mf_mtime) { |
7159a456 |
176 | push @fail_reasons, "Missing ./Makefile"; |
177 | } |
a256e995 |
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 | } |
7159a456 |
185 | } |
186 | |
187 | if (@fail_reasons) { |
188 | print STDERR <<'EOE'; |
ab340f7f |
189 | |
ab340f7f |
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, |
0424d17a |
197 | to ensure you have all required dependencies present. Not doing |
dc4600b2 |
198 | so often results in a lot of wasted time for other contributors |
23b2c49b |
199 | trying to assist you with spurious "its broken!" problems. |
ab340f7f |
200 | |
6e22e629 |
201 | By default DBICs Makefile.PL turns all optional dependencies into |
0424d17a |
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 | |
ab340f7f |
207 | If you are seeing this message unexpectedly (i.e. you are in fact |
dc4600b2 |
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 |
ab340f7f |
211 | |
212 | http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT |
213 | |
ab340f7f |
214 | The DBIC team |
215 | |
216 | |
7159a456 |
217 | Reasons you received this message: |
ab340f7f |
218 | |
219 | EOE |
220 | |
7159a456 |
221 | foreach my $r (@fail_reasons) { |
222 | print STDERR " * $r\n"; |
223 | } |
224 | print STDERR "\n\n\n"; |
225 | |
1439bf15 |
226 | require Time::HiRes; |
227 | Time::HiRes::sleep(0.005); |
228 | print STDOUT "\nBail out!\n"; |
ab340f7f |
229 | exit 1; |
230 | } |
231 | } |
232 | |
dc4600b2 |
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 |
39c9c72d |
242 | ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') ) |
dc4600b2 |
243 | ); |
244 | } |
245 | |
39c9c72d |
246 | sub is_smoker { |
6853e2c3 |
247 | return ( |
1a08c5ed |
248 | ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) |
6853e2c3 |
249 | or |
250 | __PACKAGE__->is_ci |
251 | ); |
39c9c72d |
252 | } |
253 | |
81b29c8d |
254 | sub is_ci { |
255 | return ( |
256 | ($ENV{TRAVIS}||'') eq 'true' |
257 | and |
1ab8de44 |
258 | ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| |
81b29c8d |
259 | ) |
260 | } |
261 | |
39c9c72d |
262 | sub is_plain { |
6853e2c3 |
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 | ) |
39c9c72d |
272 | } |
273 | |
ab340f7f |
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'); |
fd3d890d |
279 | my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS |
ab340f7f |
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}); |
fd3d890d |
288 | for (1 .. @mod_parts + 2) { |
ab340f7f |
289 | $root = $root->parent; |
290 | } |
291 | |
292 | return (-f $root->file ('Makefile.PL') ) |
293 | ? $root |
294 | : undef |
295 | ; |
296 | } |
297 | |
298 | 1; |