lib/Moose/Meta/Method/Accessor/Native/Collection.pm

   1 package Moose::Meta::Method::Accessor::Native::Collection;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '1.16';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use Moose::Role;
  11
  12 requires qw( _adds_members );
  13
  14 around _value_needs_copy => sub {
  15     shift;
  16     my $self = shift;
  17
  18     return $self->_constraint_must_be_checked
  19         && !$self->_check_new_members_only;
  20 };
  21
  22 around _inline_tc_code => sub {
  23     shift;
  24     my ( $self, $potential_value ) = @_;
  25
  26     return q{} unless $self->_constraint_must_be_checked;
  27
  28     if ( $self->_check_new_members_only ) {
  29         return q{} unless $self->_adds_members;
  30
  31         return $self->_inline_check_member_constraint( $self->_new_members );
  32     }
  33     else {
  34         return $self->_inline_check_coercion($potential_value) . "\n"
  35             . $self->_inline_check_constraint($potential_value);
  36     }
  37 };
  38
  39 sub _check_new_members_only {
  40     my $self = shift;
  41
  42     my $attr = $self->associated_attribute;
  43
  44     my $tc = $attr->type_constraint;
  45
  46     # If we have a coercion, we could come up with an entirely new value after
  47     # coercing, so we need to check everything,
  48     return 0 if $attr->should_coerce && $tc->has_coercion;
  49
  50     # If the parent is our root type (ArrayRef, HashRef, etc), that means we
  51     # can just check the new members of the collection, because we know that
  52     # we will always be generating an appropriate collection type.
  53     #
  54     # However, if this type has its own constraint (it's Parameteriz_able_,
  55     # not Paramet_erized_), we don't know what is being checked by the
  56     # constraint, so we need to check the whole value, not just the members.
  57     return 1
  58         if $self->_is_root_type( $tc->parent )
  59             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
  60
  61     return 0;
  62 }
  63
  64 sub _inline_check_member_constraint {
  65     my ( $self, $new_value ) = @_;
  66
  67     my $attr_name = $self->associated_attribute->name;
  68
  69     return '$member_tc->($_) || '
  70         . $self->_inline_throw_error(
  71         qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
  72             . ' . $member_tc->get_message($_)',
  73         "data => \$_"
  74         ) . " for $new_value;";
  75 }
  76
  77 around _inline_check_constraint => sub {
  78     my $orig = shift;
  79     my $self = shift;
  80
  81     return q{} unless $self->_constraint_must_be_checked;
  82
  83     return $self->$orig( $_[0] );
  84 };
  85
  86 around _inline_get_old_value_for_trigger => sub {
  87     shift;
  88     my ( $self, $instance ) = @_;
  89
  90     my $attr = $self->associated_attribute;
  91     return '' unless $attr->has_trigger;
  92
  93     return
  94           'my @old = '
  95         . $self->_inline_has($instance) . q{ ? }
  96         . $self->_inline_copy_old_value( $self->_inline_get($instance) )
  97         . ": ();\n";
  98 };
  99
 100 around _eval_environment => sub {
 101     my $orig = shift;
 102     my $self = shift;
 103
 104     my $env = $self->$orig(@_);
 105
 106     return $env
 107         unless $self->_constraint_must_be_checked
 108             && $self->_check_new_members_only;
 109
 110     $env->{'$member_tc'}
 111         = \( $self->associated_attribute->type_constraint->type_parameter
 112             ->_compiled_type_constraint );
 113
 114     return $env;
 115 };
 116
 117 no Moose::Role;
 118
 119 1;