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