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