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);
  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 modver_gt_or_eq {
  69   my ($mod, $ver) = @_;
  70
  71   croak "Nonsensical module name supplied"
  72     if ! defined $mod or ! length $mod;
  73
  74   croak "Nonsensical minimum version supplied"
  75     if ! defined $ver or $ver =~ /[^0-9\.\_]/;
  76
  77   local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
  78     if SPURIOUS_VERSION_CHECK_WARNINGS;
  79
  80   local $@;
  81   eval { $mod->VERSION($ver) } ? 1 : 0;
  82 }
  83
  84 {
  85   my $list_ctx_ok_stack_marker;
  86
  87   sub fail_on_internal_wantarray {
  88     return if $list_ctx_ok_stack_marker;
  89
  90     if (! defined wantarray) {
  91       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
  92     }
  93
  94     my $cf = 1;
  95     while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
  96
  97       # these are public API parts that alter behavior on wantarray
  98       search | search_related | slice | search_literal
  99
 100         |
 101
 102       # these are explicitly prefixed, since we only recognize them as valid
 103       # escapes when they come from the guts of CDBICompat
 104       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
 105
 106     ) $/x ) {
 107       $cf++;
 108     }
 109
 110     if (
 111       (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
 112     ) {
 113       my $obj = shift;
 114
 115       DBIx::Class::Exception->throw( sprintf (
 116         "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts",
 117         ref($obj), refaddr($obj), (caller($cf))[1,2]
 118       ), 'with_stacktrace');
 119     }
 120
 121     my $mark = [];
 122     weaken ( $list_ctx_ok_stack_marker = $mark );
 123     $mark;
 124   }
 125 }
 126
 127 1;