t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
   7   ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
   8     ||
   9   0
  10 ;
  11
  12 use Config;
  13 use Carp qw(cluck confess croak);
  14 use Fcntl ':flock';
  15 use Scalar::Util qw(blessed refaddr);
  16 use DBIx::Class::_Util qw( scope_guard parent_dir );
  17
  18 use base 'Exporter';
  19 our @EXPORT_OK = qw(
  20   dbg stacktrace
  21   local_umask find_co_root
  22   visit_namespaces
  23   check_customcond_args
  24   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
  25 );
  26
  27 if (DEBUG_TEST_CONCURRENCY_LOCKS) {
  28   require DBI;
  29   my $oc = DBI->can('connect');
  30   no warnings 'redefine';
  31   *DBI::connect = sub {
  32     DBICTest::Util::dbg("Connecting to $_[1]");
  33     goto $oc;
  34   }
  35 }
  36
  37 sub dbg ($) {
  38   require Time::HiRes;
  39   printf STDERR "\n%.06f  %5s %-78s %s\n",
  40     scalar Time::HiRes::time(),
  41     $$,
  42     $_[0],
  43     $0,
  44   ;
  45 }
  46
  47 # File locking is hard. Really hard. By far the best lock implementation
  48 # I've seen is part of the guts of File::Temp. However it is sadly not
  49 # reusable. Since I am not aware of folks doing NFS parallel testing,
  50 # nor are we known to work on VMS, I am just going to punt this and
  51 # use the portable-ish flock() provided by perl itself. If this does
  52 # not work for you - patches more than welcome.
  53 #
  54 # This figure esentially means "how long can a single test hold a
  55 # resource before everyone else gives up waiting and aborts" or
  56 # in other words "how long does the longest test-group legitimally run?"
  57 my $lock_timeout_minutes = 15;  # yes, that's long, I know
  58 my $wait_step_seconds = 0.25;
  59
  60 sub await_flock ($$) {
  61   my ($fh, $locktype) = @_;
  62
  63   my ($res, $tries);
  64   while(
  65     ! ( $res = flock( $fh, $locktype | LOCK_NB ) )
  66       and
  67     ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds
  68   ) {
  69     select( undef, undef, undef, $wait_step_seconds );
  70
  71     # "say something" every 10 cycles to work around RT#108390
  72     # jesus christ our tooling is such a crock of shit :(
  73     print "#\n" if not $tries % 10;
  74   }
  75
  76   return $res;
  77 }
  78
  79
  80 sub local_umask ($) {
  81   return unless defined $Config{d_umask};
  82
  83   croak 'Calling local_umask() in void context makes no sense'
  84     if ! defined wantarray;
  85
  86   my $old_umask = umask($_[0]);
  87   die "Setting umask failed: $!" unless defined $old_umask;
  88
  89   scope_guard(sub {
  90     local ($@, $!, $?);
  91
  92     eval {
  93       defined(umask $old_umask) or die "nope";
  94       1;
  95     } or cluck (
  96       "Unable to reset old umask '$old_umask': " . ($! || 'Unknown error')
  97     );
  98   });
  99 }
 100
 101 # Try to determine the root of a checkout/untar if possible
 102 # OR throws an exception
 103 my $co_root;
 104 sub find_co_root () {
 105
 106   $co_root ||= do {
 107
 108     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 109     my $inc_key = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 110
 111     # a bit convoluted, but what we do here essentially is:
 112     #  - get the file name of this particular module
 113     #  - do 'cd ..' as many times as necessary to get to t/lib/../..
 114
 115     my $root = $INC{$inc_key}
 116       or croak "\$INC{'$inc_key'} seems to be missing, this can't happen...";
 117
 118     $root = parent_dir $root
 119       for 1 .. @mod_parts + 2;
 120
 121     # do the check twice so that the exception is more informative in the
 122     # very unlikely case of realpath returning garbage
 123     # (Paththools are in really bad shape - handholding all the way down)
 124     for my $call_realpath (0,1) {
 125
 126       require Cwd and $root = ( Cwd::realpath($root) . '/' )
 127         if $call_realpath;
 128
 129       croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist"
 130         unless -f "${root}Makefile.PL";
 131     }
 132
 133     $root;
 134   }
 135 }
 136
 137
 138 sub stacktrace {
 139   my $frame = shift;
 140   $frame++;
 141   my (@stack, @frame);
 142
 143   while (@frame = CORE::caller($frame++)) {
 144     push @stack, [@frame[3,1,2]];
 145   }
 146
 147   return undef unless @stack;
 148
 149   $stack[0][0] = '';
 150   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 151 }
 152
 153 sub check_customcond_args ($) {
 154   my $args = shift;
 155
 156   confess "Expecting a hashref"
 157     unless ref $args eq 'HASH';
 158
 159   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 160     confess "Custom condition argument '$_' must be a plain string"
 161       if length ref $args->{$_} or ! length $args->{$_};
 162   }
 163
 164   confess "Current and legacy rel_name arguments do not match"
 165     if $args->{rel_name} ne $args->{foreign_relname};
 166
 167   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 168     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 169
 170   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 171     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 172
 173   my $struct_cnt = 0;
 174
 175   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 176     $struct_cnt++;
 177     for (qw(self_result_object self_rowobj)) {
 178       confess "Custom condition argument '$_' must be a result instance"
 179         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 180     }
 181
 182     confess "Current and legacy self_result_object arguments do not match"
 183       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 184   }
 185
 186   if (defined $args->{foreign_values}) {
 187     $struct_cnt++;
 188
 189     confess "Custom condition argument 'foreign_values' must be a hash reference"
 190       unless ref $args->{foreign_values} eq 'HASH';
 191   }
 192
 193   confess "Data structures supplied on both ends of a relationship"
 194     if $struct_cnt == 2;
 195
 196   $args;
 197 }
 198
 199 sub visit_namespaces {
 200   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 201
 202   my $visited_count = 1;
 203
 204   # A package and a namespace are subtly different things
 205   $args->{package} ||= 'main';
 206   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 207   $args->{package} =~ s/^:://;
 208
 209   if ( $args->{action}->($args->{package}) ) {
 210     my $ns =
 211       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 212         .
 213       '::'
 214     ;
 215
 216     $visited_count += visit_namespaces( %$args, package => $_ ) for
 217       grep
 218         # this happens sometimes on %:: traversal
 219         { $_ ne '::main' }
 220         map
 221           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 222           do { no strict 'refs'; keys %$ns }
 223     ;
 224   }
 225
 226   return $visited_count;
 227 }
 228
 229 1;