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