t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use ANFANG;
   7
   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 );
  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 => (
  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
  34     DBICTest::RunMode->is_smoker
  35       and
  36     ! DBICTest::RunMode->is_ci
  37   ),
  38 };
  39
  40 use base 'Exporter';
  41 our @EXPORT_OK = qw(
  42   dbg stacktrace class_seems_loaded
  43   local_umask slurp_bytes tmpdir find_co_root rm_rf
  44   capture_stderr PEEPEENESS
  45   check_customcond_args
  46   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
  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 }
  68
  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?"
  79 my $lock_timeout_minutes = 30;  # yes, that's long, I know
  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 :(
  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] );
 107       print STDOUT "#\n";
 108     }
 109   }
 110
 111   print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: "
 112     unless $res;
 113
 114   return $res;
 115 }
 116
 117
 118 sub local_umask ($) {
 119   return unless defined $Config{d_umask};
 120
 121   croak 'Calling local_umask() in void context makes no sense'
 122     if ! defined wantarray;
 123
 124   my $old_umask = umask($_[0]);
 125   croak "Setting umask failed: $!" unless defined $old_umask;
 126
 127   scope_guard(sub {
 128     local ( $!, $^E, $?, $@ );
 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   });
 137 }
 138
 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
 171     # at this point we are pretty sure this is the right thing - detaint
 172     ($root =~ /(.+)/)[0];
 173   }
 174 }
 175
 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
 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";
 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
 276 sub capture_stderr (&) {
 277   open(my $stderr_copy, '>&', *STDERR) or croak "Unable to dup STDERR: $!";
 278
 279   require File::Temp;
 280   my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() );
 281
 282   my $err_out;
 283
 284   {
 285     my $guard = scope_guard {
 286       close STDERR;
 287
 288       open(STDERR, '>&', $stderr_copy) or do {
 289         my $msg = "\n\nPANIC!!!\nFailed restore of STDERR: $!\n";
 290         print $stderr_copy $msg;
 291         print STDOUT $msg;
 292         die;
 293       };
 294
 295       close $stderr_copy;
 296     };
 297
 298     close STDERR;
 299     open( STDERR, '>&', $tf );
 300
 301     $_[0]->();
 302   }
 303
 304   slurp_bytes( "$tf" );
 305 }
 306
 307 sub slurp_bytes ($) {
 308   croak "Expecting a file name, not a filehandle" if openhandle $_[0];
 309   croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0];
 310   open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!";
 311   local $/ unless wantarray;
 312   <$fh>;
 313 }
 314
 315
 316 sub rm_rf ($) {
 317   croak "No argument supplied to rm_rf()" unless length "$_[0]";
 318
 319   return unless -e $_[0];
 320
 321 ### I do not trust myself - check for subsuming ( the right way )
 322 ### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637
 323   require Cwd;
 324
 325   my ($target, $tmp, $co_tmp) = map {
 326
 327     my $abs_fn = Cwd::abs_path("$_");
 328
 329     if ( $^O eq 'MSWin32' and length $abs_fn ) {
 330
 331       # sometimes we can get a short/longname mix, normalize everything to longnames
 332       $abs_fn = Win32::GetLongPathName($abs_fn);
 333
 334       # Fixup for unixy (as opposed to native) slashes
 335       $abs_fn =~ s|\\|/|g;
 336     }
 337
 338     $abs_fn =~ s| (?<! / ) $ |/|x
 339       if -d $abs_fn;
 340
 341     ( $abs_fn =~ /(.+)/s )[0]
 342
 343   } ( $_[0], tmpdir, find_co_root . 't/var' );
 344
 345   croak(
 346     "Path supplied to rm_rf() '$target' is neither within the local nor the "
 347   . "global scratch dirs ( '$co_tmp' and '$tmp' ): REFUSING TO `rm -rf` "
 348   . 'at random'
 349   ) unless (
 350     ( index($target, $co_tmp) == 0 and $target ne $co_tmp )
 351       or
 352     ( index($target, $tmp) == 0    and $target ne $tmp )
 353   );
 354 ###
 355
 356   require File::Path;
 357
 358   # do not ask for a recent version, use 1.x API calls
 359   File::Path::rmtree([ $target ]);
 360 }
 361
 362
 363 # This is an absolutely horrible thing to do on an end-user system
 364 # DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker
 365 # Not added to EXPORT_OK on purpose
 366 sub can_alloc_MB ($) {
 367   my $arg = shift;
 368   $arg = 'UNDEF' if not defined $arg;
 369
 370   croak "Expecting a positive integer, got '$arg'"
 371     if $arg !~ /^[1-9][0-9]*$/;
 372
 373   my ($perl) = $^X =~ /(.+)/;
 374   local $ENV{PATH};
 375   local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
 376
 377   local ( $!, $^E, $?, $@ );
 378
 379   system( $perl, qw( -It/lib -MANFANG -e ), <<'EOS', $arg );
 380 $0 = 'malloc_canary';
 381 my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 );
 382 EOS
 383
 384   !!( $? == 0 )
 385 }
 386
 387 sub stacktrace {
 388   my $frame = shift;
 389   $frame++;
 390   my (@stack, @frame);
 391
 392   while (@frame = CORE::caller($frame++)) {
 393     push @stack, [@frame[3,1,2]];
 394   }
 395
 396   return undef unless @stack;
 397
 398   $stack[0][0] = '';
 399   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 400 }
 401
 402 sub check_customcond_args ($) {
 403   my $args = shift;
 404
 405   confess "Expecting a hashref"
 406     unless ref $args eq 'HASH';
 407
 408   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 409     confess "Custom condition argument '$_' must be a plain string"
 410       if length ref $args->{$_} or ! length $args->{$_};
 411   }
 412
 413   confess "Current and legacy rel_name arguments do not match"
 414     if $args->{rel_name} ne $args->{foreign_relname};
 415
 416   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 417     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 418
 419   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 420     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 421
 422   my $struct_cnt = 0;
 423
 424   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 425     $struct_cnt++;
 426     for (qw(self_result_object self_rowobj)) {
 427       confess "Custom condition argument '$_' must be a result instance"
 428         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 429     }
 430
 431     confess "Current and legacy self_result_object arguments do not match"
 432       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 433   }
 434
 435   if (defined $args->{foreign_values}) {
 436     $struct_cnt++;
 437
 438     confess "Custom condition argument 'foreign_values' must be a hash reference"
 439       unless ref $args->{foreign_values} eq 'HASH';
 440   }
 441
 442   confess "Data structures supplied on both ends of a relationship"
 443     if $struct_cnt == 2;
 444
 445   $args;
 446 }
 447
 448 #
 449 # Replicate the *heuristic* (important!!!) implementation found in various
 450 # forms within Class::Load / Module::Inspector / Class::C3::Componentised
 451 #
 452 sub class_seems_loaded ($) {
 453
 454   croak "Function expects a class name as plain string (no references)"
 455     unless defined $_[0] and not length ref $_[0];
 456
 457   no strict 'refs';
 458
 459   return 1 if defined ${"$_[0]::VERSION"};
 460
 461   return 1 if @{"$_[0]::ISA"};
 462
 463   return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' };
 464
 465   ( !!*{"$_[0]::$_"}{CODE} ) and return 1
 466     for keys %{"$_[0]::"};
 467
 468   return 0;
 469 }
 470
 471 1;