t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 # this noop trick initializes the STDOUT, so that the TAP::Harness
   7 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
   8 # keep spinning and scheduling jobs
   9 # This results in an overall much smoother job-queue drainage, since
  10 # the Harness blocks less
  11 # (ideally this needs to be addressed in T::H, but a quick patchjob
  12 # broke everything so tabling it for now)
  13 BEGIN {
  14   if ($INC{'Test/Builder.pm'}) {
  15     local $| = 1;
  16     print "#\n";
  17   }
  18 }
  19
  20 use constant DEBUG_TEST_CONCURRENCY_LOCKS =>
  21   ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0]
  22     ||
  23   0
  24 ;
  25
  26 use Config;
  27 use Carp 'confess';
  28 use Fcntl ':flock';
  29 use Scalar::Util qw(blessed refaddr);
  30 use DBIx::Class::_Util;
  31
  32 use base 'Exporter';
  33 our @EXPORT_OK = qw(
  34   dbg stacktrace
  35   local_umask
  36   visit_namespaces
  37   check_customcond_args
  38   await_flock DEBUG_TEST_CONCURRENCY_LOCKS
  39 );
  40
  41 if (DEBUG_TEST_CONCURRENCY_LOCKS) {
  42   require DBI;
  43   my $oc = DBI->can('connect');
  44   no warnings 'redefine';
  45   *DBI::connect = sub {
  46     DBICTest::Util::dbg("Connecting to $_[1]");
  47     goto $oc;
  48   }
  49 }
  50
  51 sub dbg ($) {
  52   require Time::HiRes;
  53   printf STDERR "\n%.06f  %5s %-78s %s\n",
  54     scalar Time::HiRes::time(),
  55     $$,
  56     $_[0],
  57     $0,
  58   ;
  59 }
  60
  61 # File locking is hard. Really hard. By far the best lock implementation
  62 # I've seen is part of the guts of File::Temp. However it is sadly not
  63 # reusable. Since I am not aware of folks doing NFS parallel testing,
  64 # nor are we known to work on VMS, I am just going to punt this and
  65 # use the portable-ish flock() provided by perl itself. If this does
  66 # not work for you - patches more than welcome.
  67 #
  68 # This figure esentially means "how long can a single test hold a
  69 # resource before everyone else gives up waiting and aborts" or
  70 # in other words "how long does the longest test-group legitimally run?"
  71 my $lock_timeout_minutes = 15;  # yes, that's long, I know
  72 my $wait_step_seconds = 0.25;
  73
  74 sub await_flock ($$) {
  75   my ($fh, $locktype) = @_;
  76
  77   my ($res, $tries);
  78   while(
  79     ! ( $res = flock( $fh, $locktype | LOCK_NB ) )
  80       and
  81     ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds
  82   ) {
  83     select( undef, undef, undef, $wait_step_seconds );
  84
  85     # "say something" every 10 cycles to work around RT#108390
  86     # jesus christ our tooling is such a crock of shit :(
  87     unless ( $tries % 10 ) {
  88
  89       # Turning on autoflush is crucial: if stars align just right buffering
  90       # will ensure we never actually call write() underneath until the grand
  91       # timeout is reached (and that's too long). Reproducible via
  92       #
  93       # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \
  94       # DBICTEST_RUN_ALL_TESTS=1 \
  95       # strace -f \
  96       # prove -lj10 xt/extra/internals/
  97       #
  98       select( ( select(\*STDOUT), $|=1 )[0] );
  99
 100       print "#\n";
 101     }
 102   }
 103
 104   return $res;
 105 }
 106
 107 sub local_umask {
 108   return unless defined $Config{d_umask};
 109
 110   die 'Calling local_umask() in void context makes no sense'
 111     if ! defined wantarray;
 112
 113   my $old_umask = umask(shift());
 114   die "Setting umask failed: $!" unless defined $old_umask;
 115
 116   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
 117 }
 118 {
 119   package DBICTest::Util::UmaskGuard;
 120   sub DESTROY {
 121     &DBIx::Class::_Util::detected_reinvoked_destructor;
 122
 123     local ($@, $!);
 124     eval { defined (umask ${$_[0]}) or die };
 125     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
 126       if ($@ || $!);
 127   }
 128 }
 129
 130 sub stacktrace {
 131   my $frame = shift;
 132   $frame++;
 133   my (@stack, @frame);
 134
 135   while (@frame = caller($frame++)) {
 136     push @stack, [@frame[3,1,2]];
 137   }
 138
 139   return undef unless @stack;
 140
 141   $stack[0][0] = '';
 142   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 143 }
 144
 145 sub check_customcond_args ($) {
 146   my $args = shift;
 147
 148   confess "Expecting a hashref"
 149     unless ref $args eq 'HASH';
 150
 151   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 152     confess "Custom condition argument '$_' must be a plain string"
 153       if length ref $args->{$_} or ! length $args->{$_};
 154   }
 155
 156   confess "Current and legacy rel_name arguments do not match"
 157     if $args->{rel_name} ne $args->{foreign_relname};
 158
 159   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 160     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 161
 162   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 163     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 164
 165   my $struct_cnt = 0;
 166
 167   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 168     $struct_cnt++;
 169     for (qw(self_result_object self_rowobj)) {
 170       confess "Custom condition argument '$_' must be a result instance"
 171         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 172     }
 173
 174     confess "Current and legacy self_result_object arguments do not match"
 175       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 176   }
 177
 178   if (defined $args->{foreign_values}) {
 179     $struct_cnt++;
 180
 181     confess "Custom condition argument 'foreign_values' must be a hash reference"
 182       unless ref $args->{foreign_values} eq 'HASH';
 183   }
 184
 185   confess "Data structures supplied on both ends of a relationship"
 186     if $struct_cnt == 2;
 187
 188   $args;
 189 }
 190
 191 sub visit_namespaces {
 192   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 193
 194   my $visited_count = 1;
 195
 196   # A package and a namespace are subtly different things
 197   $args->{package} ||= 'main';
 198   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 199   $args->{package} =~ s/^:://;
 200
 201   if ( $args->{action}->($args->{package}) ) {
 202     my $ns =
 203       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 204         .
 205       '::'
 206     ;
 207
 208     $visited_count += visit_namespaces( %$args, package => $_ ) for
 209       grep
 210         # this happens sometimes on %:: traversal
 211         { $_ ne '::main' }
 212         map
 213           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 214           do { no strict 'refs'; keys %$ns }
 215     ;
 216   }
 217
 218   return $visited_count;
 219 }
 220
 221 1;