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