1 package Moose::Meta::Method::Accessor::Native::Collection;
8 requires qw( _adds_members );
10 sub _inline_coerce_new_values {
13 return unless $self->associated_attribute->should_coerce;
15 return unless $self->_tc_member_type_can_coerce;
18 '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
19 $self->_new_members . ';',
23 sub _tc_member_type_can_coerce {
26 my $member_tc = $self->_tc_member_type;
28 return $member_tc && $member_tc->has_coercion;
34 my $tc = $self->associated_attribute->type_constraint;
36 return $tc->type_parameter
37 if $tc->can('type_parameter');
44 sub _writer_value_needs_copy {
47 return $self->_constraint_must_be_checked
48 && !$self->_check_new_members_only;
53 my ($value, $tc, $coercion, $message, $is_lazy) = @_;
55 return unless $self->_constraint_must_be_checked;
57 if ($self->_check_new_members_only) {
58 return unless $self->_adds_members;
60 return $self->_inline_check_member_constraint($self->_new_members);
64 $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
65 $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
70 sub _check_new_members_only {
73 my $attr = $self->associated_attribute;
75 my $tc = $attr->type_constraint;
77 # If we have a coercion, we could come up with an entirely new value after
78 # coercing, so we need to check everything,
79 return 0 if $attr->should_coerce && $tc->has_coercion;
81 # If the parent is our root type (ArrayRef, HashRef, etc), that means we
82 # can just check the new members of the collection, because we know that
83 # we will always be generating an appropriate collection type.
85 # However, if this type has its own constraint (it's Parameteriz_able_,
86 # not Paramet_erized_), we don't know what is being checked by the
87 # constraint, so we need to check the whole value, not just the members.
89 if $self->_is_root_type( $tc->parent )
90 && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
95 sub _inline_check_member_constraint {
99 my $attr_name = $self->associated_attribute->name;
102 = $self->_tc_member_type->can_be_inlined
103 ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')'
104 : ' !$member_tc->($new_val) ';
107 'for my $new_val (' . $new_value . ') {',
109 $self->_inline_throw_error(
110 '"A new member value for ' . $attr_name
111 . ' does not pass its type constraint because: "'
112 . ' . $member_tc_obj->get_message($new_val)',
120 sub _inline_get_old_value_for_trigger {
122 my ($instance, $old) = @_;
124 my $attr = $self->associated_attribute;
125 return unless $attr->has_trigger;
128 'my ' . $old . ' = ' . $self->_has_value($instance),
129 '? ' . $self->_copy_old_value($self->_get_value($instance)),
134 around _eval_environment => sub {
138 my $env = $self->$orig(@_);
140 my $member_tc = $self->_tc_member_type;
142 return $env unless $member_tc;
144 $env->{'$member_tc_obj'} = \($member_tc);
146 $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
148 my $tc_env = $member_tc->inline_environment();
150 $env = { %{$env}, %{$tc_env} };