t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Config;
   7 use Carp 'confess';
   8 use Scalar::Util qw(blessed refaddr);
   9
  10 use base 'Exporter';
  11 our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args);
  12
  13 sub local_umask {
  14   return unless defined $Config{d_umask};
  15
  16   die 'Calling local_umask() in void context makes no sense'
  17     if ! defined wantarray;
  18
  19   my $old_umask = umask(shift());
  20   die "Setting umask failed: $!" unless defined $old_umask;
  21
  22   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
  23 }
  24 {
  25   package DBICTest::Util::UmaskGuard;
  26   sub DESTROY {
  27     local ($@, $!);
  28     eval { defined (umask ${$_[0]}) or die };
  29     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
  30       if ($@ || $!);
  31   }
  32 }
  33
  34 sub stacktrace {
  35   my $frame = shift;
  36   $frame++;
  37   my (@stack, @frame);
  38
  39   while (@frame = caller($frame++)) {
  40     push @stack, [@frame[3,1,2]];
  41   }
  42
  43   return undef unless @stack;
  44
  45   $stack[0][0] = '';
  46   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
  47 }
  48
  49 sub check_customcond_args ($) {
  50   my $args = shift;
  51
  52   confess "Expecting a hashref"
  53     unless ref $args eq 'HASH';
  54
  55   for (qw(rel_name foreign_relname self_alias foreign_alias)) {
  56     confess "Custom condition argument '$_' must be a plain string"
  57       if length ref $args->{$_} or ! length $args->{$_};
  58   }
  59
  60   confess "Current and legacy rel_name arguments do not match"
  61     if $args->{rel_name} ne $args->{foreign_relname};
  62
  63   confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
  64     unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
  65
  66   confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
  67     unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
  68
  69   if (defined $args->{self_resultobj} or defined $args->{self_rowobj} ) {
  70     for (qw(self_resultobj self_rowobj)) {
  71       confess "Custom condition argument '$_' must be a result instance"
  72         unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
  73     }
  74
  75     confess "Current and legacy self_resultobj arguments do not match"
  76       if refaddr($args->{self_resultobj}) != refaddr($args->{self_rowobj});
  77   }
  78
  79   $args;
  80 }
  81
  82 1;