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 Scalar::Util qw(blessed refaddr);
  29 use DBIx::Class::_Util;
  30
  31 use base 'Exporter';
  32 our @EXPORT_OK = qw(
  33   dbg stacktrace
  34   local_umask
  35   visit_namespaces
  36   check_customcond_args
  37   DEBUG_TEST_CONCURRENCY_LOCKS
  38 );
  39
  40 if (DEBUG_TEST_CONCURRENCY_LOCKS) {
  41   require DBI;
  42   my $oc = DBI->can('connect');
  43   no warnings 'redefine';
  44   *DBI::connect = sub {
  45     DBICTest::Util::dbg("Connecting to $_[1]");
  46     goto $oc;
  47   }
  48 }
  49
  50 sub dbg ($) {
  51   require Time::HiRes;
  52   printf STDERR "\n%.06f  %5s %-78s %s\n",
  53     scalar Time::HiRes::time(),
  54     $$,
  55     $_[0],
  56     $0,
  57   ;
  58 }
  59
  60 sub local_umask {
  61   return unless defined $Config{d_umask};
  62
  63   die 'Calling local_umask() in void context makes no sense'
  64     if ! defined wantarray;
  65
  66   my $old_umask = umask(shift());
  67   die "Setting umask failed: $!" unless defined $old_umask;
  68
  69   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
  70 }
  71 {
  72   package DBICTest::Util::UmaskGuard;
  73   sub DESTROY {
  74     &DBIx::Class::_Util::detected_reinvoked_destructor;
  75
  76     local ($@, $!);
  77     eval { defined (umask ${$_[0]}) or die };
  78     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
  79       if ($@ || $!);
  80   }
  81 }
  82
  83 sub stacktrace {
  84   my $frame = shift;
  85   $frame++;
  86   my (@stack, @frame);
  87
  88   while (@frame = CORE::caller($frame++)) {
  89     push @stack, [@frame[3,1,2]];
  90   }
  91
  92   return undef unless @stack;
  93
  94   $stack[0][0] = '';
  95   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
  96 }
  97
  98 sub check_customcond_args ($) {
  99   my $args = shift;
 100
 101   confess "Expecting a hashref"
 102     unless ref $args eq 'HASH';
 103
 104   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
 105     confess "Custom condition argument '$_' must be a plain string"
 106       if length ref $args->{$_} or ! length $args->{$_};
 107   }
 108
 109   confess "Current and legacy rel_name arguments do not match"
 110     if $args->{rel_name} ne $args->{foreign_relname};
 111
 112   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
 113     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
 114
 115   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 116     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 117
 118   my $struct_cnt = 0;
 119
 120   if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
 121     $struct_cnt++;
 122     for (qw(self_result_object self_rowobj)) {
 123       confess "Custom condition argument '$_' must be a result instance"
 124         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 125     }
 126
 127     confess "Current and legacy self_result_object arguments do not match"
 128       if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
 129   }
 130
 131   if (defined $args->{foreign_values}) {
 132     $struct_cnt++;
 133
 134     confess "Custom condition argument 'foreign_values' must be a hash reference"
 135       unless ref $args->{foreign_values} eq 'HASH';
 136   }
 137
 138   confess "Data structures supplied on both ends of a relationship"
 139     if $struct_cnt == 2;
 140
 141   $args;
 142 }
 143
 144 sub visit_namespaces {
 145   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 146
 147   my $visited_count = 1;
 148
 149   # A package and a namespace are subtly different things
 150   $args->{package} ||= 'main';
 151   $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
 152   $args->{package} =~ s/^:://;
 153
 154   if ( $args->{action}->($args->{package}) ) {
 155     my $ns =
 156       ( ($args->{package} eq 'main') ? '' :  $args->{package} )
 157         .
 158       '::'
 159     ;
 160
 161     $visited_count += visit_namespaces( %$args, package => $_ ) for
 162       grep
 163         # this happens sometimes on %:: traversal
 164         { $_ ne '::main' }
 165         map
 166           { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
 167           do { no strict 'refs'; keys %$ns }
 168     ;
 169   }
 170
 171   return $visited_count;
 172 }
 173
 174 1;