t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use ANFANG;
   7
   8 use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
   9   ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
  10     ||
  11   0
  12 ;
  13
  14 use Config;
  15 use Carp qw(cluck confess croak);
  16 use Fcntl qw( :DEFAULT :flock );
  17 use Scalar::Util qw(blessed refaddr);
  18 use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p );
  19
  20 use base 'Exporter';
  21 our @EXPORT_OK = qw(
  22   dbg stacktrace
  23   local_umask tmpdir find_co_root
  24   visit_namespaces
  25   check_customcond_args
  26   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
  27 );
  28
  29 if (DEBUG_TEST_CONCURRENCY_LOCKS) {
  30   require DBI;
  31   my $oc = DBI->can('connect');
  32   no warnings 'redefine';
  33   *DBI::connect = sub {
  34     DBICTest::Util::dbg("Connecting to $_[1]");
  35     goto $oc;
  36   }
  37 }
  38
  39 sub dbg ($) {
  40   require Time::HiRes;
  41   printf STDERR "\n%.06f  %5s %-78s %s\n",
  42     scalar Time::HiRes::time(),
  43     $$,
  44     $_[0],
  45     $0,
  46   ;
  47 }
  48
  49 # File locking is hard. Really hard. By far the best lock implementation
  50 # I've seen is part of the guts of File::Temp. However it is sadly not
  51 # reusable. Since I am not aware of folks doing NFS parallel testing,
  52 # nor are we known to work on VMS, I am just going to punt this and
  53 # use the portable-ish flock() provided by perl itself. If this does
  54 # not work for you - patches more than welcome.
  55 #
  56 # This figure esentially means "how long can a single test hold a
  57 # resource before everyone else gives up waiting and aborts" or
  58 # in other words "how long does the longest test-group legitimally run?"
  59 my $lock_timeout_minutes = 15;  # yes, that's long, I know
  60 my $wait_step_seconds = 0.25;
  61
  62 sub await_flock ($$) {
  63   my ($fh, $locktype) = @_;
  64
  65   my ($res, $tries);
  66   while(
  67     ! ( $res = flock( $fh, $locktype | LOCK_NB ) )
  68       and
  69     ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds
  70   ) {
  71     select( undef, undef, undef, $wait_step_seconds );
  72
  73     # "say something" every 10 cycles to work around RT#108390
  74     # jesus christ our tooling is such a crock of shit :(
  75     print "#\n" if not $tries % 10;
  76   }
  77
  78   return $res;
  79 }
  80
  81
  82 sub local_umask ($) {
  83   return unless defined $Config{d_umask};
  84
  85   croak 'Calling local_umask() in void context makes no sense'
  86     if ! defined wantarray;
  87
  88   my $old_umask = umask($_[0]);
  89   die "Setting umask failed: $!" unless defined $old_umask;
  90
  91   scope_guard(sub {
  92     local ($@, $!, $?);
  93
  94     eval {
  95       defined(umask $old_umask) or die "nope";
  96       1;
  97     } or cluck (
  98       "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
  99     );
 100   });
 101 }
 102
 103 # Try to determine the root of a checkout/untar if possible
 104 # OR throws an exception
 105 my $co_root;
 106 sub find_co_root () {
 107
 108   $co_root ||= do {
 109
 110     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 111     my $inc_key = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 112
 113     # a bit convoluted, but what we do here essentially is:
 114     #  - get the file name of this particular module
 115     #  - do 'cd ..' as many times as necessary to get to t/lib/../..
 116
 117     my $root = $INC{$inc_key}
 118       or croak "\$INC{'$inc_key'} seems to be missing, this can't happen...";
 119
 120     $root = parent_dir $root
 121       for 1 .. @mod_parts + 2;
 122
 123     # do the check twice so that the exception is more informative in the
 124     # very unlikely case of realpath returning garbage
 125     # (Paththools are in really bad shape - handholding all the way down)
 126     for my $call_realpath (0,1) {
 127
 128       require Cwd and $root = ( Cwd::realpath($root) . '/' )
 129         if $call_realpath;
 130
 131       croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist"
 132         unless -f "${root}Makefile.PL";
 133     }
 134
 135     # at this point we are pretty sure this is the right thing - detaint
 136     ($root =~ /(.+)/)[0];
 137   }
 138 }
 139
 140 my $tempdir;
 141 sub tmpdir () {
 142   $tempdir ||= do {
 143
 144     require File::Spec;
 145     my $dir = File::Spec->tmpdir;
 146     $dir .= '/' unless $dir =~ / [\/\\] $ /x;
 147
 148     # the above works but not always, test it to bits
 149     my $reason_dir_unusable;
 150
 151     # PathTools has a bug where on MSWin32 it will often return / as a tmpdir.
 152     # This is *really* stupid and the result of having our lockfiles all over
 153     # the place is also rather obnoxious. So we use our own heuristics instead
 154     # https://rt.cpan.org/Ticket/Display.html?id=76663
 155     my @parts = File::Spec->splitdir($dir);
 156
 157     # deal with how 'C:\\\\\\\\\\\\\\' decomposes
 158     pop @parts while @parts and ! length $parts[-1];
 159
 160     if (
 161       @parts < 2
 162         or
 163       ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x )
 164     ) {
 165       $reason_dir_unusable =
 166         'File::Spec->tmpdir returned a root directory instead of a designated '
 167       . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)';
 168     }
 169     else {
 170       # make sure we can actually create and sysopen a file in this dir
 171
 172       my $fn = $dir . "_dbictest_writability_test_$$";
 173
 174       my $u = local_umask(0); # match the umask we use in DBICTest(::Schema)
 175       my $g = scope_guard { unlink $fn };
 176
 177       eval {
 178
 179         if (-e $fn) {
 180           unlink $fn or die "Unable to unlink pre-existing $fn: $!\n";
 181         }
 182
 183         sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n";
 184
 185         print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n";
 186
 187         close $tmpfh or die "Closing $fn failed: $!\n";
 188
 189         1;
 190       }
 191         or
 192       do {
 193         chomp( my $err = $@ );
 194
 195         my @x_tests = map
 196           { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' }
 197           map
 198             { (-e, -d, -f, -r, -w, -x, -o)}
 199             ($dir, $fn)
 200         ;
 201
 202         $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests;
 203 File::Spec->tmpdir returned a directory which appears to be non-writeable:
 204
 205 Error encountered while testing '%s': %s
 206 Process EUID/EGID: %s / %s
 207 Effective umask:   %o
 208 TmpDir UID/GID:    %s / %s
 209 TmpDir StatMode:   %o
 210 TmpDir X-tests:    -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 211 TmpFile X-tests:   -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s
 212 EOE
 213       };
 214     }
 215
 216     if ($reason_dir_unusable) {
 217       # Replace with our local project tmpdir. This will make multiple tests
 218       # from different runs conflict with each other, but is much better than
 219       # polluting the root dir with random crap or failing outright
 220       my $local_dir = find_co_root . 't/var/';
 221
 222       mkdir_p $local_dir;
 223
 224       warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n";
 225       $dir = $local_dir;
 226     }
 227
 228     $dir;
 229   };
 230 }
 231
 232
 233 sub stacktrace {
 234   my $frame = shift;
 235   $frame++;
 236   my (@stack, @frame);
 237
 238   while (@frame = CORE::caller($frame++)) {
 239     push @stack, [@frame[3,1,2]];
 240   }
 241
 242   return undef unless @stack;
 243
 244   $stack[0][0] = '';
 245   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 246 }
 247
 248 sub check_customcond_args ($) {
 249   my $args = shift;
 250
 251   confess "Expecting a hashref"
 252     unless ref $args eq 'HASH';
 253
 254   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 255     confess "Custom condition argument '$_' must be a plain string"
 256       if length ref $args->{$_} or ! length $args->{$_};
 257   }
 258
 259   confess "Current and legacy rel_name arguments do not match"
 260     if $args->{rel_name} ne $args->{foreign_relname};
 261
 262   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 263     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 264
 265   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 266     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 267
 268   my $struct_cnt = 0;
 269
 270   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 271     $struct_cnt++;
 272     for (qw(self_result_object self_rowobj)) {
 273       confess "Custom condition argument '$_' must be a result instance"
 274         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 275     }
 276
 277     confess "Current and legacy self_result_object arguments do not match"
 278       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 279   }
 280
 281   if (defined $args->{foreign_values}) {
 282     $struct_cnt++;
 283
 284     confess "Custom condition argument 'foreign_values' must be a hash reference"
 285       unless ref $args->{foreign_values} eq 'HASH';
 286   }
 287
 288   confess "Data structures supplied on both ends of a relationship"
 289     if $struct_cnt == 2;
 290
 291   $args;
 292 }
 293
 294 sub visit_namespaces {
 295   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 296
 297   my $visited_count = 1;
 298
 299   # A package and a namespace are subtly different things
 300   $args->{package} ||= 'main';
 301   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 302   $args->{package} =~ s/^:://;
 303
 304   if ( $args->{action}->($args->{package}) ) {
 305     my $ns =
 306       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 307         .
 308       '::'
 309     ;
 310
 311     $visited_count += visit_namespaces( %$args, package => $_ ) for
 312       grep
 313         # this happens sometimes on %:: traversal
 314         { $_ ne '::main' }
 315         map
 316           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 317           do { no strict 'refs'; keys %$ns }
 318     ;
 319   }
 320
 321   return $visited_count;
 322 }
 323
 324 1;