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