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