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