Commit | Line | Data |
65d35121 |
1 | package DBICTest::Util; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
c0329273 |
6 | use ANFANG; |
7 | |
69016f65 |
8 | use constant DEBUG_TEST_CONCURRENCY_LOCKS => |
9 | ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] |
10 | || |
11 | 0 |
12 | ; |
13 | |
8d6b1478 |
14 | use Config; |
bbf6a9a5 |
15 | use Carp qw(cluck confess croak); |
439a7283 |
16 | use Fcntl qw( :DEFAULT :flock ); |
a446d7f8 |
17 | use Scalar::Util qw(blessed refaddr); |
439a7283 |
18 | use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); |
65d35121 |
19 | |
20 | use base 'Exporter'; |
69016f65 |
21 | our @EXPORT_OK = qw( |
22 | dbg stacktrace |
439a7283 |
23 | local_umask tmpdir find_co_root |
69016f65 |
24 | visit_namespaces |
25 | check_customcond_args |
630e2ea8 |
26 | await_flock DEBUG_TEST_CONCURRENCY_LOCKS |
69016f65 |
27 | ); |
28 | |
29 | if (DEBUG_TEST_CONCURRENCY_LOCKS) { |
30 | require DBI; |
31 | my $oc = DBI->can('connect'); |
32 | no warnings 'redefine'; |
33 | *DBI::connect = sub { |
34 | DBICTest::Util::dbg("Connecting to $_[1]"); |
35 | goto $oc; |
36 | } |
37 | } |
38 | |
39 | sub dbg ($) { |
40 | require Time::HiRes; |
41 | printf STDERR "\n%.06f %5s %-78s %s\n", |
42 | scalar Time::HiRes::time(), |
43 | $$, |
44 | $_[0], |
45 | $0, |
46 | ; |
47 | } |
8d6b1478 |
48 | |
630e2ea8 |
49 | # File locking is hard. Really hard. By far the best lock implementation |
50 | # I've seen is part of the guts of File::Temp. However it is sadly not |
51 | # reusable. Since I am not aware of folks doing NFS parallel testing, |
52 | # nor are we known to work on VMS, I am just going to punt this and |
53 | # use the portable-ish flock() provided by perl itself. If this does |
54 | # not work for you - patches more than welcome. |
55 | # |
56 | # This figure esentially means "how long can a single test hold a |
57 | # resource before everyone else gives up waiting and aborts" or |
58 | # in other words "how long does the longest test-group legitimally run?" |
59 | my $lock_timeout_minutes = 15; # yes, that's long, I know |
60 | my $wait_step_seconds = 0.25; |
61 | |
62 | sub await_flock ($$) { |
63 | my ($fh, $locktype) = @_; |
64 | |
65 | my ($res, $tries); |
66 | while( |
67 | ! ( $res = flock( $fh, $locktype | LOCK_NB ) ) |
68 | and |
69 | ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds |
70 | ) { |
71 | select( undef, undef, undef, $wait_step_seconds ); |
72 | |
73 | # "say something" every 10 cycles to work around RT#108390 |
74 | # jesus christ our tooling is such a crock of shit :( |
75 | print "#\n" if not $tries % 10; |
76 | } |
77 | |
78 | return $res; |
79 | } |
80 | |
bbf6a9a5 |
81 | |
82 | sub local_umask ($) { |
8d6b1478 |
83 | return unless defined $Config{d_umask}; |
84 | |
bbf6a9a5 |
85 | croak 'Calling local_umask() in void context makes no sense' |
8d6b1478 |
86 | if ! defined wantarray; |
87 | |
bbf6a9a5 |
88 | my $old_umask = umask($_[0]); |
8d6b1478 |
89 | die "Setting umask failed: $!" unless defined $old_umask; |
90 | |
bbf6a9a5 |
91 | scope_guard(sub { |
92 | local ($@, $!, $?); |
93 | |
94 | eval { |
95 | defined(umask $old_umask) or die "nope"; |
96 | 1; |
97 | } or cluck ( |
98 | "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error') |
99 | ); |
100 | }); |
8d6b1478 |
101 | } |
102 | |
e3be2b6f |
103 | # Try to determine the root of a checkout/untar if possible |
104 | # OR throws an exception |
105 | my $co_root; |
106 | sub find_co_root () { |
107 | |
108 | $co_root ||= do { |
109 | |
110 | my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); |
111 | my $inc_key = join ('/', @mod_parts); # %INC stores paths with / regardless of OS |
112 | |
113 | # a bit convoluted, but what we do here essentially is: |
114 | # - get the file name of this particular module |
115 | # - do 'cd ..' as many times as necessary to get to t/lib/../.. |
116 | |
117 | my $root = $INC{$inc_key} |
118 | or croak "\$INC{'$inc_key'} seems to be missing, this can't happen..."; |
119 | |
120 | $root = parent_dir $root |
121 | for 1 .. @mod_parts + 2; |
122 | |
123 | # do the check twice so that the exception is more informative in the |
124 | # very unlikely case of realpath returning garbage |
125 | # (Paththools are in really bad shape - handholding all the way down) |
126 | for my $call_realpath (0,1) { |
127 | |
128 | require Cwd and $root = ( Cwd::realpath($root) . '/' ) |
129 | if $call_realpath; |
130 | |
131 | croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist" |
132 | unless -f "${root}Makefile.PL"; |
133 | } |
134 | |
439a7283 |
135 | # at this point we are pretty sure this is the right thing - detaint |
136 | ($root =~ /(.+)/)[0]; |
e3be2b6f |
137 | } |
138 | } |
139 | |
439a7283 |
140 | my $tempdir; |
141 | sub tmpdir () { |
142 | $tempdir ||= do { |
143 | |
144 | require File::Spec; |
145 | my $dir = File::Spec->tmpdir; |
146 | $dir .= '/' unless $dir =~ / [\/\\] $ /x; |
147 | |
148 | # the above works but not always, test it to bits |
149 | my $reason_dir_unusable; |
150 | |
151 | # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. |
152 | # This is *really* stupid and the result of having our lockfiles all over |
153 | # the place is also rather obnoxious. So we use our own heuristics instead |
154 | # https://rt.cpan.org/Ticket/Display.html?id=76663 |
155 | my @parts = File::Spec->splitdir($dir); |
156 | |
157 | # deal with how 'C:\\\\\\\\\\\\\\' decomposes |
158 | pop @parts while @parts and ! length $parts[-1]; |
159 | |
160 | if ( |
161 | @parts < 2 |
162 | or |
163 | ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) |
164 | ) { |
165 | $reason_dir_unusable = |
166 | 'File::Spec->tmpdir returned a root directory instead of a designated ' |
167 | . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; |
168 | } |
169 | else { |
170 | # make sure we can actually create and sysopen a file in this dir |
171 | |
172 | my $fn = $dir . "_dbictest_writability_test_$$"; |
173 | |
174 | my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) |
175 | my $g = scope_guard { unlink $fn }; |
176 | |
177 | eval { |
178 | |
179 | if (-e $fn) { |
180 | unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; |
181 | } |
182 | |
183 | sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; |
184 | |
185 | print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; |
186 | |
187 | close $tmpfh or die "Closing $fn failed: $!\n"; |
188 | |
189 | 1; |
190 | } |
191 | or |
192 | do { |
193 | chomp( my $err = $@ ); |
194 | |
195 | my @x_tests = map |
196 | { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } |
197 | map |
198 | { (-e, -d, -f, -r, -w, -x, -o)} |
199 | ($dir, $fn) |
200 | ; |
201 | |
202 | $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; |
203 | File::Spec->tmpdir returned a directory which appears to be non-writeable: |
204 | |
205 | Error encountered while testing '%s': %s |
206 | Process EUID/EGID: %s / %s |
207 | Effective umask: %o |
208 | TmpDir UID/GID: %s / %s |
209 | TmpDir StatMode: %o |
210 | TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
211 | TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
212 | EOE |
213 | }; |
214 | } |
215 | |
216 | if ($reason_dir_unusable) { |
217 | # Replace with our local project tmpdir. This will make multiple tests |
218 | # from different runs conflict with each other, but is much better than |
219 | # polluting the root dir with random crap or failing outright |
220 | my $local_dir = find_co_root . 't/var/'; |
221 | |
222 | mkdir_p $local_dir; |
223 | |
224 | warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; |
225 | $dir = $local_dir; |
226 | } |
227 | |
228 | $dir; |
229 | }; |
230 | } |
231 | |
e3be2b6f |
232 | |
65d35121 |
233 | sub stacktrace { |
234 | my $frame = shift; |
235 | $frame++; |
236 | my (@stack, @frame); |
237 | |
821edc09 |
238 | while (@frame = CORE::caller($frame++)) { |
65d35121 |
239 | push @stack, [@frame[3,1,2]]; |
240 | } |
241 | |
242 | return undef unless @stack; |
243 | |
244 | $stack[0][0] = ''; |
245 | return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; |
246 | } |
247 | |
a3a17a15 |
248 | sub check_customcond_args ($) { |
249 | my $args = shift; |
250 | |
251 | confess "Expecting a hashref" |
252 | unless ref $args eq 'HASH'; |
253 | |
a446d7f8 |
254 | for (qw(rel_name foreign_relname self_alias foreign_alias)) { |
a3a17a15 |
255 | confess "Custom condition argument '$_' must be a plain string" |
256 | if length ref $args->{$_} or ! length $args->{$_}; |
257 | } |
258 | |
a446d7f8 |
259 | confess "Current and legacy rel_name arguments do not match" |
260 | if $args->{rel_name} ne $args->{foreign_relname}; |
261 | |
a3a17a15 |
262 | confess "Custom condition argument 'self_resultsource' must be a rsrc instance" |
263 | unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource'); |
264 | |
265 | confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc" |
a446d7f8 |
266 | unless ref $args->{self_resultsource}->relationship_info($args->{rel_name}); |
267 | |
e884e5d9 |
268 | my $struct_cnt = 0; |
1adbd3fc |
269 | |
98def3ef |
270 | if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) { |
e884e5d9 |
271 | $struct_cnt++; |
98def3ef |
272 | for (qw(self_result_object self_rowobj)) { |
a446d7f8 |
273 | confess "Custom condition argument '$_' must be a result instance" |
274 | unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row'); |
275 | } |
a3a17a15 |
276 | |
98def3ef |
277 | confess "Current and legacy self_result_object arguments do not match" |
278 | if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj}); |
a3a17a15 |
279 | } |
280 | |
e884e5d9 |
281 | if (defined $args->{foreign_values}) { |
282 | $struct_cnt++; |
1adbd3fc |
283 | |
e884e5d9 |
284 | confess "Custom condition argument 'foreign_values' must be a hash reference" |
285 | unless ref $args->{foreign_values} eq 'HASH'; |
1adbd3fc |
286 | } |
287 | |
e884e5d9 |
288 | confess "Data structures supplied on both ends of a relationship" |
289 | if $struct_cnt == 2; |
1adbd3fc |
290 | |
a3a17a15 |
291 | $args; |
292 | } |
293 | |
c9abd679 |
294 | sub visit_namespaces { |
295 | my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; |
296 | |
297 | my $visited_count = 1; |
298 | |
299 | # A package and a namespace are subtly different things |
300 | $args->{package} ||= 'main'; |
301 | $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; |
302 | $args->{package} =~ s/^:://; |
303 | |
304 | if ( $args->{action}->($args->{package}) ) { |
305 | my $ns = |
306 | ( ($args->{package} eq 'main') ? '' : $args->{package} ) |
307 | . |
308 | '::' |
309 | ; |
310 | |
311 | $visited_count += visit_namespaces( %$args, package => $_ ) for |
312 | grep |
313 | # this happens sometimes on %:: traversal |
314 | { $_ ne '::main' } |
315 | map |
316 | { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } |
317 | do { no strict 'refs'; keys %$ns } |
318 | ; |
319 | } |
320 | |
321 | return $visited_count; |
322 | } |
323 | |
65d35121 |
324 | 1; |