1 package Moose::Meta::Method::Accessor::Native::Array::Writer;
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
10 use base 'Moose::Meta::Method::Accessor::Native::Array';
12 sub _generate_method {
17 my $slot_access = $self->_inline_get($inv);
20 $code .= "\n" . $self->_inline_pre_body(@_);
22 $code .= "\n" . 'my $self = shift;';
24 $code .= "\n" . $self->_inline_check_lazy($inv);
26 $code .= "\n" . $self->_inline_curried_arguments;
28 $code .= "\n" . $self->_inline_check_argument_count;
30 $code .= "\n" . $self->_inline_process_arguments;
32 $code .= "\n" . $self->_inline_check_arguments;
34 my $new_values = $self->_new_values($slot_access);
35 my $potential_value = $self->_potential_value($slot_access);
38 . $self->_inline_tc_code(
43 $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
44 $code .= "\n" . $self->_capture_old_value($slot_access);
46 $code .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' );
48 $code .= "\n" . $self->_inline_post_body(@_);
49 $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
51 $code .= "\n" . $self->_return_value( $inv, '@old' );
58 sub _inline_process_arguments { q{} }
60 sub _inline_check_arguments { q{} }
62 sub _new_values { '@_' }
65 my ( $self, $new_value, $potential_value ) = @_;
67 return q{} unless $self->_constraint_must_be_checked;
69 if ( $self->_check_new_members_only ) {
70 return q{} unless $self->_adds_members;
72 return $self->_inline_check_member_constraint($new_value);
75 return $self->_inline_check_coercion($potential_value) . "\n"
76 . $self->_inline_check_constraint($potential_value);
80 sub _constraint_must_be_checked {
83 my $attr = $self->associated_attribute;
85 return $attr->has_type_constraint
86 && ( $attr->type_constraint->name ne 'ArrayRef'
87 || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
90 sub _check_new_members_only {
93 my $attr = $self->associated_attribute;
95 my $tc = $attr->type_constraint;
97 # If we have a coercion, we could come up with an entirely new value after
98 # coercing, so we need to check everything,
99 return 0 if $attr->should_coerce && $tc->has_coercion;
101 # If the parent is ArrayRef, that means we can just check the new members
102 # of the collection, because we know that we will always be generating an
104 return 1 if $tc->parent->name eq 'ArrayRef';
106 # If our parent is something else ( subtype 'Foo' as 'ArrayRef[Str]' )
107 # then there may be additional constraints on the whole value, as opposed
108 # to constraints just on the members.
112 sub _inline_check_member_constraint {
113 my ( $self, $new_value ) = @_;
115 my $attr_name = $self->associated_attribute->name;
117 return '$member_tc->($_) || '
118 . $self->_inline_throw_error(
119 qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
120 . ' . $member_tc->get_message($_)',
122 ) . " for $new_value;";
125 sub _inline_check_coercion {
126 my ( $self, $value ) = @_;
128 my $attr = $self->associated_attribute;
131 unless $attr->should_coerce && $attr->type_constraint->has_coercion;
133 # We want to break the aliasing in @_ in case the coercion tries to make a
134 # destructive change to an array member.
135 my $code = 'my @copy = @{ $value }';
136 return '@_ = @{ $attr->type_constraint->coerce(\@copy) };';
139 sub _inline_check_constraint {
142 return q{} unless $self->_constraint_must_be_checked;
144 return $self->SUPER::_inline_check_constraint(@_);
147 sub _capture_old_value { return q{} }
148 sub _return_value { return q{} }
150 sub _eval_environment {
153 my $env = $self->SUPER::_eval_environment;
156 unless $self->_constraint_must_be_checked
157 and $self->_check_new_members_only;
160 = \( $self->associated_attribute->type_constraint->type_parameter
161 ->_compiled_type_constraint );