1 package Moose::Meta::Method::Accessor::Native::Collection;
6 our $AUTHORITY = 'cpan:STEVAN';
10 requires qw( _adds_members );
12 sub _inline_coerce_new_values {
15 return unless $self->associated_attribute->should_coerce;
17 return unless $self->_tc_member_type_can_coerce;
20 '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
21 $self->_new_members . ';',
25 sub _tc_member_type_can_coerce {
28 my $member_tc = $self->_tc_member_type;
30 return $member_tc && $member_tc->has_coercion;
36 my $tc = $self->associated_attribute->type_constraint;
38 return $tc->type_parameter
39 if $tc->can('type_parameter');
46 sub _writer_value_needs_copy {
49 return $self->_constraint_must_be_checked
50 && !$self->_check_new_members_only;
56 return unless $self->_constraint_must_be_checked;
58 if ($self->_check_new_members_only) {
59 return unless $self->_adds_members;
61 return $self->_inline_check_member_constraint($self->_new_members);
65 $self->_inline_check_coercion(@_),
66 $self->_inline_check_constraint(@_),
71 sub _check_new_members_only {
74 my $attr = $self->associated_attribute;
76 my $tc = $attr->type_constraint;
78 # If we have a coercion, we could come up with an entirely new value after
79 # coercing, so we need to check everything,
80 return 0 if $attr->should_coerce && $tc->has_coercion;
82 # If the parent is our root type (ArrayRef, HashRef, etc), that means we
83 # can just check the new members of the collection, because we know that
84 # we will always be generating an appropriate collection type.
86 # However, if this type has its own constraint (it's Parameteriz_able_,
87 # not Paramet_erized_), we don't know what is being checked by the
88 # constraint, so we need to check the whole value, not just the members.
90 if $self->_is_root_type( $tc->parent )
91 && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
96 sub _inline_check_member_constraint {
100 my $attr_name = $self->associated_attribute->name;
103 'for (' . $new_value . ') {',
104 'if (!$member_tc->($_)) {',
105 $self->_inline_throw_error(
106 '"A new member value for ' . $attr_name
107 . ' does not pass its type constraint because: "'
108 . ' . $member_tc_obj->get_message($_)',
116 sub _inline_get_old_value_for_trigger {
118 my ($instance, $old) = @_;
120 my $attr = $self->associated_attribute;
121 return unless $attr->has_trigger;
124 'my ' . $old . ' = ' . $self->_has_value($instance),
125 '? ' . $self->_copy_old_value($self->_get_value($instance)),
130 around _eval_environment => sub {
134 my $env = $self->$orig(@_);
136 my $member_tc = $self->_tc_member_type;
138 return $env unless $member_tc;
140 $env->{'$member_tc_obj'} = \($member_tc);
142 $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );