1 package Moose::Meta::Method::Accessor::Native::Array::Writer;
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
11 Moose::Meta::Method::Accessor::Native::Array
12 Moose::Meta::Method::Accessor::Native::Writer
17 sub _value_needs_copy {
20 return $self->_constraint_must_be_checked
21 && !$self->_check_new_members_only;
25 my ( $self, $new_value, $potential_value ) = @_;
27 return q{} unless $self->_constraint_must_be_checked;
29 if ( $self->_check_new_members_only ) {
30 return q{} unless $self->_adds_members;
32 return $self->_inline_check_member_constraint($new_value);
35 return $self->_inline_check_coercion($potential_value) . "\n"
36 . $self->_inline_check_constraint($potential_value);
40 sub _constraint_must_be_checked {
43 my $attr = $self->associated_attribute;
45 return $attr->has_type_constraint
46 && ( $attr->type_constraint->name ne 'ArrayRef'
47 || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
50 sub _check_new_members_only {
53 my $attr = $self->associated_attribute;
55 my $tc = $attr->type_constraint;
57 # If we have a coercion, we could come up with an entirely new value after
58 # coercing, so we need to check everything,
59 return 0 if $attr->should_coerce && $tc->has_coercion;
61 # If the parent is ArrayRef, that means we can just check the new members
62 # of the collection, because we know that we will always be generating an
63 # ArrayRef. However, if this type has its own constraint, we don't know
64 # what the constraint checks, so we need to check the whole value, not
67 if $tc->parent->name eq 'ArrayRef'
68 && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
73 sub _inline_check_member_constraint {
74 my ( $self, $new_value ) = @_;
76 my $attr_name = $self->associated_attribute->name;
78 return '$member_tc->($_) || '
79 . $self->_inline_throw_error(
80 qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
81 . ' . $member_tc->get_message($_)',
83 ) . " for $new_value;";
86 sub _inline_check_coercion {
87 my ( $self, $value ) = @_;
89 my $attr = $self->associated_attribute;
92 unless $attr->should_coerce && $attr->type_constraint->has_coercion;
94 return "$value = \$type_constraint_obj->coerce($value);";
97 sub _inline_check_constraint {
100 return q{} unless $self->_constraint_must_be_checked;
102 return $self->SUPER::_inline_check_constraint( $_[0] );
105 sub _inline_get_old_value_for_trigger {
106 my ( $self, $instance ) = @_;
108 my $attr = $self->associated_attribute;
109 return '' unless $attr->has_trigger;
111 my $mi = $attr->associated_class->get_meta_instance;
112 my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
116 . $pred . q{ ? } . '[ @{'
117 . $self->_inline_get($instance)
118 . '} ] : ()' . ";\n";
121 sub _eval_environment {
124 my $env = $self->SUPER::_eval_environment;
127 unless $self->_constraint_must_be_checked
128 and $self->_check_new_members_only;
131 = \( $self->associated_attribute->type_constraint->type_parameter
132 ->_compiled_type_constraint );