t/lib/DBICTest/Util.pm

   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     unless ( $tries % 10 ) {
  92
  93       # Turning on autoflush is crucial: if stars align just right buffering
  94       # will ensure we never actually call write() underneath until the grand
  95       # timeout is reached (and that's too long). Reproducible via
  96       #
  97       # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \
  98       # DBICTEST_RUN_ALL_TESTS=1 \
  99       # strace -f \
 100       # prove -lj10 xt/extra/internals/
 101       #
 102       select( ( select(\*STDOUT), $|=1 )[0] );
 103
 104       print "#\n";
 105     }
 106   }
 107
 108   return $res;
 109 }
 110
 111
 112 sub local_umask ($) {
 113   return unless defined $Config{d_umask};
 114
 115   croak 'Calling local_umask() in void context makes no sense'
 116     if ! defined wantarray;
 117
 118   my $old_umask = umask($_[0]);
 119   croak "Setting umask failed: $!" unless defined $old_umask;
 120
 121   scope_guard(sub {
 122     local ($@, $!, $?);
 123
 124     eval {
 125       defined(umask $old_umask) or die "nope";
 126       1;
 127     } or cluck (
 128       "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
 129     );
 130   });
 131 }
 132
 133 # Try to determine the root of a checkout/untar if possible
 134 # OR throws an exception
 135 my $co_root;
 136 sub find_co_root () {
 137
 138   $co_root ||= do {
 139
 140     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 141     my $inc_key = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 142
 143     # a bit convoluted, but what we do here essentially is:
 144     #  - get the file name of this particular module
 145     #  - do 'cd ..' as many times as necessary to get to t/lib/../..
 146
 147     my $root = $INC{$inc_key}
 148       or croak "\$INC{'$inc_key'} seems to be missing, this can't happen...";
 149
 150     $root = parent_dir $root
 151       for 1 .. @mod_parts + 2;
 152
 153     # do the check twice so that the exception is more informative in the
 154     # very unlikely case of realpath returning garbage
 155     # (Paththools are in really bad shape - handholding all the way down)
 156     for my $call_realpath (0,1) {
 157
 158       require Cwd and $root = ( Cwd::realpath($root) . '/' )
 159         if $call_realpath;
 160
 161       croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist"
 162         unless -f "${root}Makefile.PL";
 163     }
 164
 165     # at this point we are pretty sure this is the right thing - detaint
 166     ($root =~ /(.+)/)[0];
 167   }
 168 }
 169
 170 my $tempdir;
 171 sub tmpdir () {
 172   $tempdir ||= do {
 173
 174     require File::Spec;
 175     my $dir = File::Spec->tmpdir;
 176     $dir .= '/' unless $dir =~ / [\/\\] $ /x;
 177
 178     # the above works but not always, test it to bits
 179     my $reason_dir_unusable;
 180
 181     # PathTools has a bug where on MSWin32 it will often return / as a tmpdir.
 182     # This is *really* stupid and the result of having our lockfiles all over
 183     # the place is also rather obnoxious. So we use our own heuristics instead
 184     # https://rt.cpan.org/Ticket/Display.html?id=76663
 185     my @parts = File::Spec->splitdir($dir);
 186
 187     # deal with how 'C:\\\\\\\\\\\\\\' decomposes
 188     pop @parts while @parts and ! length $parts[-1];
 189
 190     if (
 191       @parts < 2
 192         or
 193       ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x )
 194     ) {
 195       $reason_dir_unusable =
 196         'File::Spec->tmpdir returned a root directory instead of a designated '
 197       . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)';
 198     }
 199     else {
 200       # make sure we can actually create and sysopen a file in this dir
 201
 202       my $fn = $dir . "_dbictest_writability_test_$$";
 203
 204       my $u = local_umask(0); # match the umask we use in DBICTest(::Schema)
 205       my $g = scope_guard { unlink $fn };
 206
 207       eval {
 208
 209         if (-e $fn) {
 210           unlink $fn or die "Unable to unlink pre-existing $fn: $!\n";
 211         }
 212
 213         sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n";
 214
 215         print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n";
 216
 217         close $tmpfh or die "Closing $fn failed: $!\n";
 218
 219         1;
 220       }
 221         or
 222       do {
 223         chomp( my $err = $@ );
 224
 225         my @x_tests = map
 226           { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' }
 227           map
 228             { (-e, -d, -f, -r, -w, -x, -o)}
 229             ($dir, $fn)
 230         ;
 231
 232         $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests;
 233 File::Spec->tmpdir returned a directory which appears to be non-writeable:
 234
 235 Error encountered while testing '%s': %s
 236 Process EUID/EGID: %s / %s
 237 Effective umask:   %o
 238 TmpDir UID/GID:    %s / %s
 239 TmpDir StatMode:   %o
 240 TmpDir X-tests:    -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 241 TmpFile X-tests:   -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 242 EOE
 243       };
 244     }
 245
 246     if ($reason_dir_unusable) {
 247       # Replace with our local project tmpdir. This will make multiple tests
 248       # from different runs conflict with each other, but is much better than
 249       # polluting the root dir with random crap or failing outright
 250       my $local_dir = find_co_root . 't/var/';
 251
 252       mkdir_p $local_dir;
 253
 254       warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n";
 255       $dir = $local_dir;
 256     }
 257
 258     $dir;
 259   };
 260 }
 261
 262
 263 sub slurp_bytes ($) {
 264   croak "Expecting a file name, not a filehandle" if openhandle $_[0];
 265   croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0];
 266   open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!";
 267   local $/ unless wantarray;
 268   <$fh>;
 269 }
 270
 271
 272 sub rm_rf ($) {
 273   croak "No valid argument supplied to rm_rf()" unless length "$_[0]";
 274
 275   return unless -e $_[0];
 276
 277 ### I do not trust myself - check for subsuming ( the right way )
 278 ### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637
 279   require Cwd;
 280
 281   my ($target, $tmp, $co_tmp) = map {
 282
 283     my $abs_fn = Cwd::abs_path("$_");
 284
 285     if ( $^O eq 'MSWin32' and length $abs_fn ) {
 286
 287       # sometimes we can get a short/longname mix, normalize everything to longnames
 288       $abs_fn = Win32::GetLongPathName($abs_fn);
 289
 290       # Fixup for unixy (as opposed to native) slashes
 291       $abs_fn =~ s|\\|/|g;
 292     }
 293
 294     $abs_fn =~ s| (?<! / ) $ |/|x
 295       if -d $abs_fn;
 296
 297     ( $abs_fn =~ /(.+)/s )[0]
 298
 299   } ( $_[0], tmpdir, find_co_root . 't/var' );
 300
 301   croak(
 302     "Path supplied to rm_rf() '$target' is neither within the local nor the "
 303   . "global scratch dirs ( '$co_tmp' and '$tmp' ): REFUSING TO `rm -rf` "
 304   . 'at random'
 305   ) unless (
 306     ( index($target, $co_tmp) == 0 and $target ne $co_tmp )
 307       or
 308     ( index($target, $tmp) == 0    and $target ne $tmp )
 309   );
 310 ###
 311
 312   require File::Path;
 313
 314   # do not ask for a recent version, use 1.x API calls
 315   File::Path::rmtree([ $target ]);
 316 }
 317
 318
 319 # This is an absolutely horrible thing to do on an end-user system
 320 # DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker
 321 # Not added to EXPORT_OK on purpose
 322 sub can_alloc_MB ($) {
 323   my $arg = shift;
 324   $arg = 'UNDEF' if not defined $arg;
 325
 326   croak "Expecting a positive integer, got '$arg'"
 327     if $arg !~ /^[1-9][0-9]*$/;
 328
 329   my ($perl) = $^X =~ /(.+)/;
 330   local $ENV{PATH};
 331   local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
 332
 333   local ( $!, $^E, $?, $@ );
 334
 335   system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg );
 336 $0 = 'malloc_canary';
 337 my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 );
 338 EOS
 339
 340   !!( $? == 0 )
 341 }
 342
 343 sub stacktrace {
 344   my $frame = shift;
 345   $frame++;
 346   my (@stack, @frame);
 347
 348   while (@frame = CORE::caller($frame++)) {
 349     push @stack, [@frame[3,1,2]];
 350   }
 351
 352   return undef unless @stack;
 353
 354   $stack[0][0] = '';
 355   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 356 }
 357
 358 sub check_customcond_args ($) {
 359   my $args = shift;
 360
 361   confess "Expecting a hashref"
 362     unless ref $args eq 'HASH';
 363
 364   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 365     confess "Custom condition argument '$_' must be a plain string"
 366       if length ref $args->{$_} or ! length $args->{$_};
 367   }
 368
 369   confess "Current and legacy rel_name arguments do not match"
 370     if $args->{rel_name} ne $args->{foreign_relname};
 371
 372   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 373     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 374
 375   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 376     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 377
 378   my $struct_cnt = 0;
 379
 380   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 381     $struct_cnt++;
 382     for (qw(self_result_object self_rowobj)) {
 383       confess "Custom condition argument '$_' must be a result instance"
 384         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 385     }
 386
 387     confess "Current and legacy self_result_object arguments do not match"
 388       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 389   }
 390
 391   if (defined $args->{foreign_values}) {
 392     $struct_cnt++;
 393
 394     confess "Custom condition argument 'foreign_values' must be a hash reference"
 395       unless ref $args->{foreign_values} eq 'HASH';
 396   }
 397
 398   confess "Data structures supplied on both ends of a relationship"
 399     if $struct_cnt == 2;
 400
 401   $args;
 402 }
 403
 404 sub visit_namespaces {
 405   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 406
 407   my $visited_count = 1;
 408
 409   # A package and a namespace are subtly different things
 410   $args->{package} ||= 'main';
 411   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 412   $args->{package} =~ s/^:://;
 413
 414   if ( $args->{action}->($args->{package}) ) {
 415     my $ns =
 416       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 417         .
 418       '::'
 419     ;
 420
 421     $visited_count += visit_namespaces( %$args, package => $_ ) for
 422       grep
 423         # this happens sometimes on %:: traversal
 424         { $_ ne '::main' }
 425         map
 426           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 427           do { no strict 'refs'; keys %$ns }
 428     ;
 429   }
 430
 431   return $visited_count;
 432 }
 433
 434 1;