lib/DBIx/Class/_Util.pm

   1 package # hide from PAUSE
   2   DBIx::Class::_Util;
   3
   4 use warnings;
   5 use strict;
   6
   7 use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0);
   8
   9 BEGIN {
  10   package # hide from pause
  11     DBIx::Class::_ENV_;
  12
  13   use Config;
  14
  15   use constant {
  16
  17     # but of course
  18     BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0,
  19
  20     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
  21
  22     # ::Runmode would only be loaded by DBICTest, which in turn implies t/
  23     DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0,
  24
  25     # During 5.13 dev cycle HELEMs started to leak on copy
  26     PEEPEENESS =>
  27       # request for all tests would force "non-leaky" illusion and vice-versa
  28       defined $ENV{DBICTEST_ALL_LEAKS}                                              ? !$ENV{DBICTEST_ALL_LEAKS}
  29       # otherwise confess that this perl is busted ONLY on smokers
  30     : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006)  ? 1
  31       # otherwise we are good
  32                                                                                     : 0
  33     ,
  34
  35     ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
  36
  37     IV_SIZE => $Config{ivsize},
  38
  39     OS_NAME => $^O,
  40   };
  41
  42   if ($] < 5.009_005) {
  43     require MRO::Compat;
  44     constant->import( OLD_MRO => 1 );
  45   }
  46   else {
  47     require mro;
  48     constant->import( OLD_MRO => 0 );
  49   }
  50 }
  51
  52 use Carp;
  53 use Scalar::Util qw(refaddr weaken);
  54
  55 use base 'Exporter';
  56 our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount);
  57
  58 sub sigwarn_silencer {
  59   my $pattern = shift;
  60
  61   croak "Expecting a regexp" if ref $pattern ne 'Regexp';
  62
  63   my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
  64
  65   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
  66 }
  67
  68 sub refcount {
  69   croak "Expecting a reference" if ! length ref $_[0];
  70
  71   require B;
  72   # No tempvars - must operate on $_[0], otherwise the pad
  73   # will count as an extra ref
  74   B::svref_2object($_[0])->REFCNT;
  75 }
  76
  77 sub modver_gt_or_eq {
  78   my ($mod, $ver) = @_;
  79
  80   croak "Nonsensical module name supplied"
  81     if ! defined $mod or ! length $mod;
  82
  83   croak "Nonsensical minimum version supplied"
  84     if ! defined $ver or $ver =~ /[^0-9\.\_]/;
  85
  86   local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
  87     if SPURIOUS_VERSION_CHECK_WARNINGS;
  88
  89   local $@;
  90   eval { $mod->VERSION($ver) } ? 1 : 0;
  91 }
  92
  93 {
  94   my $list_ctx_ok_stack_marker;
  95
  96   sub fail_on_internal_wantarray {
  97     return if $list_ctx_ok_stack_marker;
  98
  99     if (! defined wantarray) {
 100       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
 101     }
 102
 103     my $cf = 1;
 104     while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
 105
 106       # these are public API parts that alter behavior on wantarray
 107       search | search_related | slice | search_literal
 108
 109         |
 110
 111       # these are explicitly prefixed, since we only recognize them as valid
 112       # escapes when they come from the guts of CDBICompat
 113       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
 114
 115     ) $/x ) {
 116       $cf++;
 117     }
 118
 119     if (
 120       (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
 121     ) {
 122       my $obj = shift;
 123
 124       DBIx::Class::Exception->throw( sprintf (
 125         "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts",
 126         ref($obj), refaddr($obj), (caller($cf))[1,2]
 127       ), 'with_stacktrace');
 128     }
 129
 130     my $mark = [];
 131     weaken ( $list_ctx_ok_stack_marker = $mark );
 132     $mark;
 133   }
 134 }
 135
 136 1;