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 );
  35
  36 use base 'Exporter';
  37 our @EXPORT_OK = qw(
  38   dbg stacktrace class_seems_loaded
  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       # Generlly this should be handled by ANFANG, but double-check ourselves
 253       # Not using mkdir_p here: we *know* everything else up until 'var' exists
 254       # If it doesn't - we better fail outright
 255       # (also saves an extra File::Path require(), small enough as it is)
 256       -d $local_dir
 257         or
 258       mkdir $local_dir
 259         or
 260       die "Unable to create build-local tempdir '$local_dir': $!\n";
 261
 262       warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n";
 263       $dir = $local_dir;
 264     }
 265
 266     $dir;
 267   };
 268 }
 269
 270
 271 sub slurp_bytes ($) {
 272   croak "Expecting a file name, not a filehandle" if openhandle $_[0];
 273   croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0];
 274   open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!";
 275   local $/ unless wantarray;
 276   <$fh>;
 277 }
 278
 279
 280 sub rm_rf ($) {
 281   croak "No valid argument supplied to rm_rf()" unless length "$_[0]";
 282
 283   return unless -e $_[0];
 284
 285 ### I do not trust myself - check for subsuming ( the right way )
 286 ### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637
 287   require Cwd;
 288
 289   my ($target, $tmp, $co_tmp) = map {
 290
 291     my $abs_fn = Cwd::abs_path("$_");
 292
 293     if ( $^O eq 'MSWin32' and length $abs_fn ) {
 294
 295       # sometimes we can get a short/longname mix, normalize everything to longnames
 296       $abs_fn = Win32::GetLongPathName($abs_fn);
 297
 298       # Fixup for unixy (as opposed to native) slashes
 299       $abs_fn =~ s|\\|/|g;
 300     }
 301
 302     $abs_fn =~ s| (?<! / ) $ |/|x
 303       if -d $abs_fn;
 304
 305     ( $abs_fn =~ /(.+)/s )[0]
 306
 307   } ( $_[0], tmpdir, find_co_root . 't/var' );
 308
 309   croak(
 310     "Path supplied to rm_rf() '$target' is neither within the local nor the "
 311   . "global scratch dirs ( '$co_tmp' and '$tmp' ): REFUSING TO `rm -rf` "
 312   . 'at random'
 313   ) unless (
 314     ( index($target, $co_tmp) == 0 and $target ne $co_tmp )
 315       or
 316     ( index($target, $tmp) == 0    and $target ne $tmp )
 317   );
 318 ###
 319
 320   require File::Path;
 321
 322   # do not ask for a recent version, use 1.x API calls
 323   File::Path::rmtree([ $target ]);
 324 }
 325
 326
 327 # This is an absolutely horrible thing to do on an end-user system
 328 # DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker
 329 # Not added to EXPORT_OK on purpose
 330 sub can_alloc_MB ($) {
 331   my $arg = shift;
 332   $arg = 'UNDEF' if not defined $arg;
 333
 334   croak "Expecting a positive integer, got '$arg'"
 335     if $arg !~ /^[1-9][0-9]*$/;
 336
 337   my ($perl) = $^X =~ /(.+)/;
 338   local $ENV{PATH};
 339   local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
 340
 341   local ( $!, $^E, $?, $@ );
 342
 343   system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg );
 344 $0 = 'malloc_canary';
 345 my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 );
 346 EOS
 347
 348   !!( $? == 0 )
 349 }
 350
 351 sub stacktrace {
 352   my $frame = shift;
 353   $frame++;
 354   my (@stack, @frame);
 355
 356   while (@frame = CORE::caller($frame++)) {
 357     push @stack, [@frame[3,1,2]];
 358   }
 359
 360   return undef unless @stack;
 361
 362   $stack[0][0] = '';
 363   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 364 }
 365
 366 sub check_customcond_args ($) {
 367   my $args = shift;
 368
 369   confess "Expecting a hashref"
 370     unless ref $args eq 'HASH';
 371
 372   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 373     confess "Custom condition argument '$_' must be a plain string"
 374       if length ref $args->{$_} or ! length $args->{$_};
 375   }
 376
 377   confess "Current and legacy rel_name arguments do not match"
 378     if $args->{rel_name} ne $args->{foreign_relname};
 379
 380   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 381     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 382
 383   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 384     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 385
 386   my $struct_cnt = 0;
 387
 388   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 389     $struct_cnt++;
 390     for (qw(self_result_object self_rowobj)) {
 391       confess "Custom condition argument '$_' must be a result instance"
 392         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 393     }
 394
 395     confess "Current and legacy self_result_object arguments do not match"
 396       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 397   }
 398
 399   if (defined $args->{foreign_values}) {
 400     $struct_cnt++;
 401
 402     confess "Custom condition argument 'foreign_values' must be a hash reference"
 403       unless ref $args->{foreign_values} eq 'HASH';
 404   }
 405
 406   confess "Data structures supplied on both ends of a relationship"
 407     if $struct_cnt == 2;
 408
 409   $args;
 410 }
 411
 412 sub visit_namespaces {
 413   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 414
 415   my $visited_count = 1;
 416
 417   # A package and a namespace are subtly different things
 418   $args->{package} ||= 'main';
 419   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 420   $args->{package} =~ s/^:://;
 421
 422   if ( $args->{action}->($args->{package}) ) {
 423     my $ns =
 424       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 425         .
 426       '::'
 427     ;
 428
 429     $visited_count += visit_namespaces( %$args, package => $_ ) for
 430       grep
 431         # this happens sometimes on %:: traversal
 432         { $_ ne '::main' }
 433         map
 434           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 435           do { no strict 'refs'; keys %$ns }
 436     ;
 437   }
 438
 439   return $visited_count;
 440 }
 441
 442 #
 443 # Replicate the *heuristic* (important!!!) implementation found in various
 444 # forms within Class::Load / Module::Inspector / Class::C3::Componentised
 445 #
 446 sub class_seems_loaded ($) {
 447
 448   croak "Function expects a class name as plain string (no references)"
 449     unless defined $_[0] and not length ref $_[0];
 450
 451   no strict 'refs';
 452
 453   return 1 if defined ${"$_[0]::VERSION"};
 454
 455   return 1 if @{"$_[0]::ISA"};
 456
 457   return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' };
 458
 459   ( !!*{"$_[0]::$_"}{CODE} ) and return 1
 460     for keys %{"$_[0]::"};
 461
 462   return 0;
 463 }
 464
 465 1;