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     print "#\n" if not $tries % 10;
  88   }
  89
  90   return $res;
  91 }
  92
  93 sub local_umask {
  94   return unless defined $Config{d_umask};
  95
  96   die 'Calling local_umask() in void context makes no sense'
  97     if ! defined wantarray;
  98
  99   my $old_umask = umask(shift());
 100   die "Setting umask failed: $!" unless defined $old_umask;
 101
 102   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
 103 }
 104 {
 105   package DBICTest::Util::UmaskGuard;
 106   sub DESTROY {
 107     &DBIx::Class::_Util::detected_reinvoked_destructor;
 108
 109     local ($@, $!);
 110     eval { defined (umask ${$_[0]}) or die };
 111     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
 112       if ($@ || $!);
 113   }
 114 }
 115
 116 sub stacktrace {
 117   my $frame = shift;
 118   $frame++;
 119   my (@stack, @frame);
 120
 121   while (@frame = CORE::caller($frame++)) {
 122     push @stack, [@frame[3,1,2]];
 123   }
 124
 125   return undef unless @stack;
 126
 127   $stack[0][0] = '';
 128   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 129 }
 130
 131 sub check_customcond_args ($) {
 132   my $args = shift;
 133
 134   confess "Expecting a hashref"
 135     unless ref $args eq 'HASH';
 136
 137   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 138     confess "Custom condition argument '$_' must be a plain string"
 139       if length ref $args->{$_} or ! length $args->{$_};
 140   }
 141
 142   confess "Current and legacy rel_name arguments do not match"
 143     if $args->{rel_name} ne $args->{foreign_relname};
 144
 145   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 146     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 147
 148   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 149     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 150
 151   my $struct_cnt = 0;
 152
 153   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 154     $struct_cnt++;
 155     for (qw(self_result_object self_rowobj)) {
 156       confess "Custom condition argument '$_' must be a result instance"
 157         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 158     }
 159
 160     confess "Current and legacy self_result_object arguments do not match"
 161       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 162   }
 163
 164   if (defined $args->{foreign_values}) {
 165     $struct_cnt++;
 166
 167     confess "Custom condition argument 'foreign_values' must be a hash reference"
 168       unless ref $args->{foreign_values} eq 'HASH';
 169   }
 170
 171   confess "Data structures supplied on both ends of a relationship"
 172     if $struct_cnt == 2;
 173
 174   $args;
 175 }
 176
 177 sub visit_namespaces {
 178   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 179
 180   my $visited_count = 1;
 181
 182   # A package and a namespace are subtly different things
 183   $args->{package} ||= 'main';
 184   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 185   $args->{package} =~ s/^:://;
 186
 187   if ( $args->{action}->($args->{package}) ) {
 188     my $ns =
 189       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 190         .
 191       '::'
 192     ;
 193
 194     $visited_count += visit_namespaces( %$args, package => $_ ) for
 195       grep
 196         # this happens sometimes on %:: traversal
 197         { $_ ne '::main' }
 198         map
 199           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 200           do { no strict 'refs'; keys %$ns }
 201     ;
 202   }
 203
 204   return $visited_count;
 205 }
 206
 207 1;