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 use Carp;
  10 use Scalar::Util qw(refaddr weaken);
  11
  12 use base 'Exporter';
  13 our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray);
  14
  15 sub sigwarn_silencer {
  16   my $pattern = shift;
  17
  18   croak "Expecting a regexp" if ref $pattern ne 'Regexp';
  19
  20   my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
  21
  22   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
  23 }
  24
  25 sub modver_gt_or_eq {
  26   my ($mod, $ver) = @_;
  27
  28   croak "Nonsensical module name supplied"
  29     if ! defined $mod or ! length $mod;
  30
  31   croak "Nonsensical minimum version supplied"
  32     if ! defined $ver or $ver =~ /[^0-9\.\_]/;
  33
  34   local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
  35     if SPURIOUS_VERSION_CHECK_WARNINGS;
  36
  37   local $@;
  38   eval { $mod->VERSION($ver) } ? 1 : 0;
  39 }
  40
  41 {
  42   my $list_ctx_ok_stack_marker;
  43
  44   sub fail_on_internal_wantarray {
  45     return if $list_ctx_ok_stack_marker;
  46
  47     if (! defined wantarray) {
  48       croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
  49     }
  50
  51     my $cf = 1;
  52     while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
  53
  54       # these are public API parts that alter behavior on wantarray
  55       search | search_related | slice | search_literal
  56
  57         |
  58
  59       # these are explicitly prefixed, since we only recognize them as valid
  60       # escapes when they come from the guts of CDBICompat
  61       CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
  62
  63     ) $/x ) {
  64       $cf++;
  65     }
  66
  67     if (
  68       (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
  69     ) {
  70       my $obj = shift;
  71
  72       DBIx::Class::Exception->throw( sprintf (
  73         "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts",
  74         ref($obj), refaddr($obj), (caller($cf))[1,2]
  75       ), 'with_stacktrace');
  76     }
  77
  78     my $mark = [];
  79     weaken ( $list_ctx_ok_stack_marker = $mark );
  80     $mark;
  81   }
  82 }
  83
  84 1;