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