Commit | Line | Data |
65d35121 |
1 | package DBICTest::Util; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
c0329273 |
6 | use ANFANG; |
7 | |
3605497b |
8 | use Config; |
9 | use Carp qw(cluck confess croak); |
10 | use Fcntl qw( :DEFAULT :flock ); |
11 | use Scalar::Util qw( blessed refaddr openhandle ); |
12 | use DBIx::Class::_Util qw( scope_guard parent_dir ); |
08a8d8f1 |
13 | |
14 | use constant { |
15 | |
16 | DEBUG_TEST_CONCURRENCY_LOCKS => ( |
17 | ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] |
18 | || |
19 | 0 |
20 | ), |
21 | |
22 | # During 5.13 dev cycle HELEMs started to leak on copy |
23 | # add an escape for these perls ON SMOKERS - a user/CI will still get death |
24 | # constname a homage to http://theoatmeal.com/comics/working_home |
25 | PEEPEENESS => ( |
3605497b |
26 | ( |
27 | DBIx::Class::_ENV_::PERL_VERSION >= 5.013005 |
28 | and |
29 | DBIx::Class::_ENV_::PERL_VERSION <= 5.013006 |
30 | ) |
31 | and |
32 | require DBICTest::RunMode |
33 | and |
08a8d8f1 |
34 | DBICTest::RunMode->is_smoker |
35 | and |
36 | ! DBICTest::RunMode->is_ci |
08a8d8f1 |
37 | ), |
38 | }; |
69016f65 |
39 | |
65d35121 |
40 | use base 'Exporter'; |
69016f65 |
41 | our @EXPORT_OK = qw( |
817ac9e9 |
42 | dbg stacktrace class_seems_loaded |
e48635f7 |
43 | local_umask slurp_bytes tmpdir find_co_root rm_rf |
10be570e |
44 | PEEPEENESS |
69016f65 |
45 | check_customcond_args |
630e2ea8 |
46 | await_flock DEBUG_TEST_CONCURRENCY_LOCKS |
69016f65 |
47 | ); |
48 | |
49 | if (DEBUG_TEST_CONCURRENCY_LOCKS) { |
50 | require DBI; |
51 | my $oc = DBI->can('connect'); |
52 | no warnings 'redefine'; |
53 | *DBI::connect = sub { |
54 | DBICTest::Util::dbg("Connecting to $_[1]"); |
55 | goto $oc; |
56 | } |
57 | } |
58 | |
59 | sub dbg ($) { |
60 | require Time::HiRes; |
61 | printf STDERR "\n%.06f %5s %-78s %s\n", |
62 | scalar Time::HiRes::time(), |
63 | $$, |
64 | $_[0], |
65 | $0, |
66 | ; |
67 | } |
8d6b1478 |
68 | |
630e2ea8 |
69 | # File locking is hard. Really hard. By far the best lock implementation |
70 | # I've seen is part of the guts of File::Temp. However it is sadly not |
71 | # reusable. Since I am not aware of folks doing NFS parallel testing, |
72 | # nor are we known to work on VMS, I am just going to punt this and |
73 | # use the portable-ish flock() provided by perl itself. If this does |
74 | # not work for you - patches more than welcome. |
75 | # |
76 | # This figure esentially means "how long can a single test hold a |
77 | # resource before everyone else gives up waiting and aborts" or |
78 | # in other words "how long does the longest test-group legitimally run?" |
501d6e06 |
79 | my $lock_timeout_minutes = 30; # yes, that's long, I know |
630e2ea8 |
80 | my $wait_step_seconds = 0.25; |
81 | |
82 | sub await_flock ($$) { |
83 | my ($fh, $locktype) = @_; |
84 | |
85 | my ($res, $tries); |
86 | while( |
87 | ! ( $res = flock( $fh, $locktype | LOCK_NB ) ) |
88 | and |
89 | ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds |
90 | ) { |
91 | select( undef, undef, undef, $wait_step_seconds ); |
92 | |
93 | # "say something" every 10 cycles to work around RT#108390 |
94 | # jesus christ our tooling is such a crock of shit :( |
820a2936 |
95 | unless ( $tries % 10 ) { |
96 | |
97 | # Turning on autoflush is crucial: if stars align just right buffering |
98 | # will ensure we never actually call write() underneath until the grand |
99 | # timeout is reached (and that's too long). Reproducible via |
100 | # |
101 | # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \ |
102 | # DBICTEST_RUN_ALL_TESTS=1 \ |
103 | # strace -f \ |
104 | # prove -lj10 xt/extra/internals/ |
105 | # |
106 | select( ( select(\*STDOUT), $|=1 )[0] ); |
7db939de |
107 | print STDOUT "#\n"; |
820a2936 |
108 | } |
630e2ea8 |
109 | } |
110 | |
501d6e06 |
111 | print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: " |
112 | unless $res; |
113 | |
630e2ea8 |
114 | return $res; |
115 | } |
116 | |
bbf6a9a5 |
117 | |
118 | sub local_umask ($) { |
8d6b1478 |
119 | return unless defined $Config{d_umask}; |
120 | |
bbf6a9a5 |
121 | croak 'Calling local_umask() in void context makes no sense' |
8d6b1478 |
122 | if ! defined wantarray; |
123 | |
bbf6a9a5 |
124 | my $old_umask = umask($_[0]); |
e48635f7 |
125 | croak "Setting umask failed: $!" unless defined $old_umask; |
8d6b1478 |
126 | |
bbf6a9a5 |
127 | scope_guard(sub { |
7db939de |
128 | local ( $!, $^E, $?, $@ ); |
bbf6a9a5 |
129 | |
130 | eval { |
131 | defined(umask $old_umask) or die "nope"; |
132 | 1; |
133 | } or cluck ( |
134 | "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error') |
135 | ); |
136 | }); |
8d6b1478 |
137 | } |
138 | |
e3be2b6f |
139 | # Try to determine the root of a checkout/untar if possible |
140 | # OR throws an exception |
141 | my $co_root; |
142 | sub find_co_root () { |
143 | |
144 | $co_root ||= do { |
145 | |
146 | my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); |
147 | my $inc_key = join ('/', @mod_parts); # %INC stores paths with / regardless of OS |
148 | |
149 | # a bit convoluted, but what we do here essentially is: |
150 | # - get the file name of this particular module |
151 | # - do 'cd ..' as many times as necessary to get to t/lib/../.. |
152 | |
153 | my $root = $INC{$inc_key} |
154 | or croak "\$INC{'$inc_key'} seems to be missing, this can't happen..."; |
155 | |
156 | $root = parent_dir $root |
157 | for 1 .. @mod_parts + 2; |
158 | |
159 | # do the check twice so that the exception is more informative in the |
160 | # very unlikely case of realpath returning garbage |
161 | # (Paththools are in really bad shape - handholding all the way down) |
162 | for my $call_realpath (0,1) { |
163 | |
164 | require Cwd and $root = ( Cwd::realpath($root) . '/' ) |
165 | if $call_realpath; |
166 | |
167 | croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist" |
168 | unless -f "${root}Makefile.PL"; |
169 | } |
170 | |
439a7283 |
171 | # at this point we are pretty sure this is the right thing - detaint |
172 | ($root =~ /(.+)/)[0]; |
e3be2b6f |
173 | } |
174 | } |
175 | |
439a7283 |
176 | my $tempdir; |
177 | sub tmpdir () { |
178 | $tempdir ||= do { |
179 | |
180 | require File::Spec; |
181 | my $dir = File::Spec->tmpdir; |
182 | $dir .= '/' unless $dir =~ / [\/\\] $ /x; |
183 | |
184 | # the above works but not always, test it to bits |
185 | my $reason_dir_unusable; |
186 | |
187 | # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. |
188 | # This is *really* stupid and the result of having our lockfiles all over |
189 | # the place is also rather obnoxious. So we use our own heuristics instead |
190 | # https://rt.cpan.org/Ticket/Display.html?id=76663 |
191 | my @parts = File::Spec->splitdir($dir); |
192 | |
193 | # deal with how 'C:\\\\\\\\\\\\\\' decomposes |
194 | pop @parts while @parts and ! length $parts[-1]; |
195 | |
196 | if ( |
197 | @parts < 2 |
198 | or |
199 | ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) |
200 | ) { |
201 | $reason_dir_unusable = |
202 | 'File::Spec->tmpdir returned a root directory instead of a designated ' |
203 | . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; |
204 | } |
205 | else { |
206 | # make sure we can actually create and sysopen a file in this dir |
207 | |
208 | my $fn = $dir . "_dbictest_writability_test_$$"; |
209 | |
210 | my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) |
211 | my $g = scope_guard { unlink $fn }; |
212 | |
213 | eval { |
214 | |
215 | if (-e $fn) { |
216 | unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; |
217 | } |
218 | |
219 | sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; |
220 | |
221 | print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; |
222 | |
223 | close $tmpfh or die "Closing $fn failed: $!\n"; |
224 | |
225 | 1; |
226 | } |
227 | or |
228 | do { |
229 | chomp( my $err = $@ ); |
230 | |
231 | my @x_tests = map |
232 | { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } |
233 | map |
234 | { (-e, -d, -f, -r, -w, -x, -o)} |
235 | ($dir, $fn) |
236 | ; |
237 | |
238 | $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; |
239 | File::Spec->tmpdir returned a directory which appears to be non-writeable: |
240 | |
241 | Error encountered while testing '%s': %s |
242 | Process EUID/EGID: %s / %s |
243 | Effective umask: %o |
244 | TmpDir UID/GID: %s / %s |
245 | TmpDir StatMode: %o |
246 | TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
247 | TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s |
248 | EOE |
249 | }; |
250 | } |
251 | |
252 | if ($reason_dir_unusable) { |
253 | # Replace with our local project tmpdir. This will make multiple tests |
254 | # from different runs conflict with each other, but is much better than |
255 | # polluting the root dir with random crap or failing outright |
256 | my $local_dir = find_co_root . 't/var/'; |
257 | |
17afd4ef |
258 | # Generlly this should be handled by ANFANG, but double-check ourselves |
259 | # Not using mkdir_p here: we *know* everything else up until 'var' exists |
260 | # If it doesn't - we better fail outright |
261 | # (also saves an extra File::Path require(), small enough as it is) |
262 | -d $local_dir |
263 | or |
264 | mkdir $local_dir |
265 | or |
266 | die "Unable to create build-local tempdir '$local_dir': $!\n"; |
439a7283 |
267 | |
268 | warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; |
269 | $dir = $local_dir; |
270 | } |
271 | |
272 | $dir; |
273 | }; |
274 | } |
275 | |
e3be2b6f |
276 | |
e48635f7 |
277 | sub slurp_bytes ($) { |
278 | croak "Expecting a file name, not a filehandle" if openhandle $_[0]; |
279 | croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0]; |
280 | open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!"; |
281 | local $/ unless wantarray; |
282 | <$fh>; |
283 | } |
284 | |
285 | |
286 | sub rm_rf ($) { |
501d6e06 |
287 | croak "No argument supplied to rm_rf()" unless length "$_[0]"; |
e48635f7 |
288 | |
289 | return unless -e $_[0]; |
290 | |
291 | ### I do not trust myself - check for subsuming ( the right way ) |
292 | ### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637 |
293 | require Cwd; |
294 | |
295 | my ($target, $tmp, $co_tmp) = map { |
296 | |
297 | my $abs_fn = Cwd::abs_path("$_"); |
298 | |
299 | if ( $^O eq 'MSWin32' and length $abs_fn ) { |
300 | |
301 | # sometimes we can get a short/longname mix, normalize everything to longnames |
302 | $abs_fn = Win32::GetLongPathName($abs_fn); |
303 | |
304 | # Fixup for unixy (as opposed to native) slashes |
305 | $abs_fn =~ s|\\|/|g; |
306 | } |
307 | |
308 | $abs_fn =~ s| (?<! / ) $ |/|x |
309 | if -d $abs_fn; |
310 | |
311 | ( $abs_fn =~ /(.+)/s )[0] |
312 | |
313 | } ( $_[0], tmpdir, find_co_root . 't/var' ); |
314 | |
315 | croak( |
316 | "Path supplied to rm_rf() '$target' is neither within the local nor the " |
317 | . "global scratch dirs ( '$co_tmp' and '$tmp' ): REFUSING TO `rm -rf` " |
318 | . 'at random' |
319 | ) unless ( |
320 | ( index($target, $co_tmp) == 0 and $target ne $co_tmp ) |
321 | or |
322 | ( index($target, $tmp) == 0 and $target ne $tmp ) |
323 | ); |
324 | ### |
325 | |
326 | require File::Path; |
327 | |
328 | # do not ask for a recent version, use 1.x API calls |
329 | File::Path::rmtree([ $target ]); |
330 | } |
331 | |
332 | |
24fbd7fb |
333 | # This is an absolutely horrible thing to do on an end-user system |
334 | # DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker |
335 | # Not added to EXPORT_OK on purpose |
336 | sub can_alloc_MB ($) { |
337 | my $arg = shift; |
338 | $arg = 'UNDEF' if not defined $arg; |
339 | |
340 | croak "Expecting a positive integer, got '$arg'" |
341 | if $arg !~ /^[1-9][0-9]*$/; |
342 | |
343 | my ($perl) = $^X =~ /(.+)/; |
344 | local $ENV{PATH}; |
345 | local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); |
346 | |
347 | local ( $!, $^E, $?, $@ ); |
348 | |
349 | system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg ); |
350 | $0 = 'malloc_canary'; |
351 | my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 ); |
352 | EOS |
353 | |
354 | !!( $? == 0 ) |
355 | } |
356 | |
65d35121 |
357 | sub stacktrace { |
358 | my $frame = shift; |
359 | $frame++; |
360 | my (@stack, @frame); |
361 | |
821edc09 |
362 | while (@frame = CORE::caller($frame++)) { |
65d35121 |
363 | push @stack, [@frame[3,1,2]]; |
364 | } |
365 | |
366 | return undef unless @stack; |
367 | |
368 | $stack[0][0] = ''; |
369 | return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; |
370 | } |
371 | |
a3a17a15 |
372 | sub check_customcond_args ($) { |
373 | my $args = shift; |
374 | |
375 | confess "Expecting a hashref" |
376 | unless ref $args eq 'HASH'; |
377 | |
a446d7f8 |
378 | for (qw(rel_name foreign_relname self_alias foreign_alias)) { |
a3a17a15 |
379 | confess "Custom condition argument '$_' must be a plain string" |
380 | if length ref $args->{$_} or ! length $args->{$_}; |
381 | } |
382 | |
a446d7f8 |
383 | confess "Current and legacy rel_name arguments do not match" |
384 | if $args->{rel_name} ne $args->{foreign_relname}; |
385 | |
a3a17a15 |
386 | confess "Custom condition argument 'self_resultsource' must be a rsrc instance" |
387 | unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource'); |
388 | |
389 | confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc" |
a446d7f8 |
390 | unless ref $args->{self_resultsource}->relationship_info($args->{rel_name}); |
391 | |
e884e5d9 |
392 | my $struct_cnt = 0; |
1adbd3fc |
393 | |
98def3ef |
394 | if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) { |
e884e5d9 |
395 | $struct_cnt++; |
98def3ef |
396 | for (qw(self_result_object self_rowobj)) { |
a446d7f8 |
397 | confess "Custom condition argument '$_' must be a result instance" |
398 | unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row'); |
399 | } |
a3a17a15 |
400 | |
98def3ef |
401 | confess "Current and legacy self_result_object arguments do not match" |
402 | if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj}); |
a3a17a15 |
403 | } |
404 | |
e884e5d9 |
405 | if (defined $args->{foreign_values}) { |
406 | $struct_cnt++; |
1adbd3fc |
407 | |
e884e5d9 |
408 | confess "Custom condition argument 'foreign_values' must be a hash reference" |
409 | unless ref $args->{foreign_values} eq 'HASH'; |
1adbd3fc |
410 | } |
411 | |
e884e5d9 |
412 | confess "Data structures supplied on both ends of a relationship" |
413 | if $struct_cnt == 2; |
1adbd3fc |
414 | |
a3a17a15 |
415 | $args; |
416 | } |
417 | |
817ac9e9 |
418 | # |
419 | # Replicate the *heuristic* (important!!!) implementation found in various |
420 | # forms within Class::Load / Module::Inspector / Class::C3::Componentised |
421 | # |
422 | sub class_seems_loaded ($) { |
423 | |
424 | croak "Function expects a class name as plain string (no references)" |
425 | unless defined $_[0] and not length ref $_[0]; |
426 | |
427 | no strict 'refs'; |
428 | |
429 | return 1 if defined ${"$_[0]::VERSION"}; |
430 | |
431 | return 1 if @{"$_[0]::ISA"}; |
432 | |
433 | return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' }; |
434 | |
435 | ( !!*{"$_[0]::$_"}{CODE} ) and return 1 |
436 | for keys %{"$_[0]::"}; |
437 | |
438 | return 0; |
439 | } |
440 | |
65d35121 |
441 | 1; |