Commit | Line | Data |
4bea1fe7 |
1 | package # hide from PAUSE |
39c9c72d |
2 | DBICTest::RunMode; |
ab340f7f |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Path::Class qw/file dir/; |
fa19e5d6 |
8 | use Fcntl ':DEFAULT'; |
9 | use File::Spec (); |
10 | use File::Temp (); |
e3be2b6f |
11 | use DBICTest::Util qw( local_umask find_co_root ); |
12 | |
13 | # Try to determine the root of a checkout/untar if possible |
14 | # return a Path::Class::Dir object or undef |
15 | sub _find_co_root { eval { dir( find_co_root() ) } } |
ab340f7f |
16 | |
9b871b00 |
17 | # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. |
18 | # This is *really* stupid and the result of having our lockfiles all over |
19 | # the place is also rather obnoxious. So we use our own heuristics instead |
20 | # https://rt.cpan.org/Ticket/Display.html?id=76663 |
21 | my $tmpdir; |
22 | sub tmpdir { |
85143769 |
23 | dir ($tmpdir ||= do { |
9b871b00 |
24 | |
fa19e5d6 |
25 | # works but not always |
9b871b00 |
26 | my $dir = dir(File::Spec->tmpdir); |
fa19e5d6 |
27 | my $reason_dir_unusable; |
9b871b00 |
28 | |
29 | my @parts = File::Spec->splitdir($dir); |
6bbdf31d |
30 | if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) { |
fa19e5d6 |
31 | $reason_dir_unusable = |
32 | 'File::Spec->tmpdir returned a root directory instead of a designated ' |
33 | . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; |
34 | } |
35 | else { |
36 | # make sure we can actually create and sysopen a file in this dir |
37 | local $@; |
0a03f539 |
38 | my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) |
3ba92e4a |
39 | my $tempfile = '<NONCREATABLE>'; |
fa19e5d6 |
40 | eval { |
3ba92e4a |
41 | $tempfile = File::Temp->new( |
42 | TEMPLATE => '_dbictest_writability_test_XXXXXX', |
fa19e5d6 |
43 | DIR => "$dir", |
44 | UNLINK => 1, |
45 | ); |
3ba92e4a |
46 | close $tempfile or die "closing $tempfile failed: $!\n"; |
47 | |
48 | sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; |
49 | print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; |
50 | close $tempfh2 or die "closing $tempfile failed: $!\n"; |
fa19e5d6 |
51 | 1; |
52 | } or do { |
53 | chomp( my $err = $@ ); |
3ba92e4a |
54 | my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); |
0a03f539 |
55 | $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; |
fa19e5d6 |
56 | File::Spec->tmpdir returned a directory which appears to be non-writeable: |
57 | Error encountered while testing '%s': %s |
58 | Process EUID/EGID: %s / %s |
0a03f539 |
59 | Effective umask: %o |
fa19e5d6 |
60 | TmpDir UID/GID: %s / %s |
61 | TmpDir StatMode: %o |
62 | TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
63 | TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
64 | EOE |
65 | }; |
66 | } |
67 | |
68 | if ($reason_dir_unusable) { |
9b871b00 |
69 | # Replace with our local project tmpdir. This will make multiple runs |
70 | # from different runs conflict with each other, but is much better than |
fa19e5d6 |
71 | # polluting the root dir with random crap or failing outright |
72 | my $local_dir = _find_co_root()->subdir('t')->subdir('var'); |
73 | $local_dir->mkpath; |
74 | |
75 | warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; |
76 | $dir = $local_dir; |
9b871b00 |
77 | } |
78 | |
85143769 |
79 | $dir->stringify; |
80 | }); |
9b871b00 |
81 | } |
82 | |
83 | |
dc4600b2 |
84 | # Mimic $Module::Install::AUTHOR |
85 | sub is_author { |
86 | |
dc4600b2 |
87 | return ( |
7b87b77c |
88 | ! -d 'inc/Module' |
dc4600b2 |
89 | or |
7b87b77c |
90 | -e 'inc/.author' |
dc4600b2 |
91 | ); |
92 | } |
93 | |
39c9c72d |
94 | sub is_smoker { |
6853e2c3 |
95 | return ( |
1a08c5ed |
96 | ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) |
6853e2c3 |
97 | or |
98 | __PACKAGE__->is_ci |
99 | ); |
39c9c72d |
100 | } |
101 | |
81b29c8d |
102 | sub is_ci { |
103 | return ( |
104 | ($ENV{TRAVIS}||'') eq 'true' |
105 | and |
1ab8de44 |
106 | ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| |
81b29c8d |
107 | ) |
108 | } |
109 | |
39c9c72d |
110 | sub is_plain { |
6853e2c3 |
111 | return ( |
112 | ! $ENV{RELEASE_TESTING} |
113 | and |
114 | ! $ENV{DBICTEST_RUN_ALL_TESTS} |
115 | and |
116 | ! __PACKAGE__->is_smoker |
117 | and |
118 | ! __PACKAGE__->is_author |
119 | ) |
39c9c72d |
120 | } |
121 | |
ab340f7f |
122 | 1; |