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 'scope_guard';
  17
  18 use base 'Exporter';
  19 our @EXPORT_OK = qw(
  20   dbg stacktrace
  21   local_umask
  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 sub stacktrace {
 102   my $frame = shift;
 103   $frame++;
 104   my (@stack, @frame);
 105
 106   while (@frame = CORE::caller($frame++)) {
 107     push @stack, [@frame[3,1,2]];
 108   }
 109
 110   return undef unless @stack;
 111
 112   $stack[0][0] = '';
 113   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 114 }
 115
 116 sub check_customcond_args ($) {
 117   my $args = shift;
 118
 119   confess "Expecting a hashref"
 120     unless ref $args eq 'HASH';
 121
 122   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 123     confess "Custom condition argument '$_' must be a plain string"
 124       if length ref $args->{$_} or ! length $args->{$_};
 125   }
 126
 127   confess "Current and legacy rel_name arguments do not match"
 128     if $args->{rel_name} ne $args->{foreign_relname};
 129
 130   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 131     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 132
 133   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 134     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 135
 136   my $struct_cnt = 0;
 137
 138   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 139     $struct_cnt++;
 140     for (qw(self_result_object self_rowobj)) {
 141       confess "Custom condition argument '$_' must be a result instance"
 142         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 143     }
 144
 145     confess "Current and legacy self_result_object arguments do not match"
 146       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 147   }
 148
 149   if (defined $args->{foreign_values}) {
 150     $struct_cnt++;
 151
 152     confess "Custom condition argument 'foreign_values' must be a hash reference"
 153       unless ref $args->{foreign_values} eq 'HASH';
 154   }
 155
 156   confess "Data structures supplied on both ends of a relationship"
 157     if $struct_cnt == 2;
 158
 159   $args;
 160 }
 161
 162 sub visit_namespaces {
 163   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 164
 165   my $visited_count = 1;
 166
 167   # A package and a namespace are subtly different things
 168   $args->{package} ||= 'main';
 169   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 170   $args->{package} =~ s/^:://;
 171
 172   if ( $args->{action}->($args->{package}) ) {
 173     my $ns =
 174       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 175         .
 176       '::'
 177     ;
 178
 179     $visited_count += visit_namespaces( %$args, package => $_ ) for
 180       grep
 181         # this happens sometimes on %:: traversal
 182         { $_ ne '::main' }
 183         map
 184           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 185           do { no strict 'refs'; keys %$ns }
 186     ;
 187   }
 188
 189   return $visited_count;
 190 }
 191
 192 1;