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
  40   if ($] < 5.009_005) {
  41     require MRO::Compat;
  42     constant->import( OLD_MRO => 1 );
  43   }
  44   else {
  45     require mro;
  46     constant->import( OLD_MRO => 0 );
  47   }
  48 }
  49
  50 use Carp;
  51 use Scalar::Util qw(refaddr weaken);
  52
  53 use base 'Exporter';
  54 our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray);
  55
  56 sub sigwarn_silencer {
  57   my $pattern = shift;
  58
  59   croak "Expecting a regexp" if ref $pattern ne 'Regexp';
  60
  61   my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
  62
  63   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
  64 }
  65
  66 sub modver_gt_or_eq {
  67   my ($mod, $ver) = @_;
  68
  69   croak "Nonsensical module name supplied"
  70     if ! defined $mod or ! length $mod;
  71
  72   croak "Nonsensical minimum version supplied"
  73     if ! defined $ver or $ver =~ /[^0-9\.\_]/;
  74
  75   local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
  76     if SPURIOUS_VERSION_CHECK_WARNINGS;
  77
  78   local $@;
  79   eval { $mod->VERSION($ver) } ? 1 : 0;
  80 }
  81
  82 {
  83   my $list_ctx_ok_stack_marker;
  84
  85   sub fail_on_internal_wantarray {
  86     return if $list_ctx_ok_stack_marker;
  87
  88     if (! defined wantarray) {
  89       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
  90     }
  91
  92     my $cf = 1;
  93     while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
  94
  95       # these are public API parts that alter behavior on wantarray
  96       search | search_related | slice | search_literal
  97
  98         |
  99
 100       # these are explicitly prefixed, since we only recognize them as valid
 101       # escapes when they come from the guts of CDBICompat
 102       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
 103
 104     ) $/x ) {
 105       $cf++;
 106     }
 107
 108     if (
 109       (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
 110     ) {
 111       my $obj = shift;
 112
 113       DBIx::Class::Exception->throw( sprintf (
 114         "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts",
 115         ref($obj), refaddr($obj), (caller($cf))[1,2]
 116       ), 'with_stacktrace');
 117     }
 118
 119     my $mark = [];
 120     weaken ( $list_ctx_ok_stack_marker = $mark );
 121     $mark;
 122   }
 123 }
 124
 125 1;