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
  43 use base 'Exporter';
  44 our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args);
  45
  46 sub local_umask {
  47   return unless defined $Config{d_umask};
  48
  49   die 'Calling local_umask() in void context makes no sense'
  50     if ! defined wantarray;
  51
  52   my $old_umask = umask(shift());
  53   die "Setting umask failed: $!" unless defined $old_umask;
  54
  55   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
  56 }
  57 {
  58   package DBICTest::Util::UmaskGuard;
  59   sub DESTROY {
  60     local ($@, $!);
  61     eval { defined (umask ${$_[0]}) or die };
  62     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
  63       if ($@ || $!);
  64   }
  65 }
  66
  67 sub stacktrace {
  68   my $frame = shift;
  69   $frame++;
  70   my (@stack, @frame);
  71
  72   while (@frame = caller($frame++)) {
  73     push @stack, [@frame[3,1,2]];
  74   }
  75
  76   return undef unless @stack;
  77
  78   $stack[0][0] = '';
  79   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
  80 }
  81
  82 sub check_customcond_args ($) {
  83   my $args = shift;
  84
  85   confess "Expecting a hashref"
  86     unless ref $args eq 'HASH';
  87
  88   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
  89     confess "Custom condition argument '$_' must be a plain string"
  90       if length ref $args->{$_} or ! length $args->{$_};
  91   }
  92
  93   confess "Current and legacy rel_name arguments do not match"
  94     if $args->{rel_name} ne $args->{foreign_relname};
  95
  96   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
  97     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
  98
  99   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
 100     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
 101
 102   my $rowobj_cnt = 0;
 103
 104   if (defined $args->{self_resultobj} or defined $args->{self_rowobj} ) {
 105     $rowobj_cnt++;
 106     for (qw(self_resultobj self_rowobj)) {
 107       confess "Custom condition argument '$_' must be a result instance"
 108         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
 109     }
 110
 111     confess "Current and legacy self_resultobj arguments do not match"
 112       if refaddr($args->{self_resultobj}) != refaddr($args->{self_rowobj});
 113   }
 114
 115   if (defined $args->{foreign_resultobj}) {
 116     $rowobj_cnt++;
 117
 118     confess "Custom condition argument 'foreign_resultobj' must be a result instance"
 119       unless defined blessed $args->{foreign_resultobj} and $args->{foreign_resultobj}->isa('DBIx::Class::Row');
 120   }
 121
 122   confess "Result objects supplied on both ends of a relationship"
 123     if $rowobj_cnt == 2;
 124
 125   $args;
 126 }
 127
 128 1;