1 package Moose::Meta::Method::Accessor::Native::Collection;
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
12 requires qw( _adds_members );
14 around _inline_coerce_new_values => sub {
18 return q{} unless $self->associated_attribute->should_coerce;
20 return q{} unless $self->_tc_member_type_can_coerce;
25 . ') = map { $member_tc_obj->coerce($_) } '
26 . $self->_new_members . ';';
29 sub _tc_member_type_can_coerce {
32 my $member_tc = $self->_tc_member_type;
34 return $member_tc && $member_tc->has_coercion;
41 my $tc = $self->associated_attribute->type_constraint;
46 return $tc->type_parameter
47 if $tc->can('type_parameter');
53 around _value_needs_copy => sub {
57 return $self->_constraint_must_be_checked
58 && !$self->_check_new_members_only;
61 around _inline_tc_code => sub {
63 my ( $self, $potential_value ) = @_;
65 return q{} unless $self->_constraint_must_be_checked;
67 if ( $self->_check_new_members_only ) {
68 return q{} unless $self->_adds_members;
70 return $self->_inline_check_member_constraint( $self->_new_members );
73 return $self->_inline_check_coercion($potential_value) . "\n"
74 . $self->_inline_check_constraint($potential_value);
78 sub _check_new_members_only {
81 my $attr = $self->associated_attribute;
83 my $tc = $attr->type_constraint;
85 # If we have a coercion, we could come up with an entirely new value after
86 # coercing, so we need to check everything,
87 return 0 if $attr->should_coerce && $tc->has_coercion;
89 # If the parent is our root type (ArrayRef, HashRef, etc), that means we
90 # can just check the new members of the collection, because we know that
91 # we will always be generating an appropriate collection type.
93 # However, if this type has its own constraint (it's Parameteriz_able_,
94 # not Paramet_erized_), we don't know what is being checked by the
95 # constraint, so we need to check the whole value, not just the members.
97 if $self->_is_root_type( $tc->parent )
98 && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
103 sub _inline_check_member_constraint {
104 my ( $self, $new_value ) = @_;
106 my $attr_name = $self->associated_attribute->name;
108 return '$member_tc->($_) || '
109 . $self->_inline_throw_error(
110 qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
111 . ' . $member_tc->get_message($_)',
113 ) . " for $new_value;";
116 around _inline_get_old_value_for_trigger => sub {
118 my ( $self, $instance ) = @_;
120 my $attr = $self->associated_attribute;
121 return '' unless $attr->has_trigger;
125 . $self->_inline_has($instance) . q{ ? }
126 . $self->_inline_copy_old_value( $self->_inline_get($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 );