Commit | Line | Data |
f7fd22b6 |
1 | package Moose::Meta::Method::Accessor::Native::Array::Writer; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | our $VERSION = '1.13'; |
7 | $VERSION = eval $VERSION; |
8 | our $AUTHORITY = 'cpan:STEVAN'; |
9 | |
5df54980 |
10 | use base qw( |
11 | Moose::Meta::Method::Accessor::Native::Array |
12 | Moose::Meta::Method::Accessor::Native::Writer |
13 | ); |
f7fd22b6 |
14 | |
5df54980 |
15 | sub _inline_process_arguments {q{}} |
e29372ff |
16 | |
5df54980 |
17 | sub _inline_check_arguments {q{}} |
a7821be5 |
18 | |
5df54980 |
19 | sub _new_value {'@_'} |
a7821be5 |
20 | |
5df54980 |
21 | sub _inline_copy_value { |
22 | my ( $self, $potential_ref ) = @_; |
a7821be5 |
23 | |
5df54980 |
24 | return q{} unless $self->_value_needs_copy; |
a7821be5 |
25 | |
5df54980 |
26 | my $code = "my \@potential = ${$potential_ref};"; |
a7821be5 |
27 | |
5df54980 |
28 | ${$potential_ref} = '@potential'; |
a7821be5 |
29 | |
30 | return $code; |
31 | } |
32 | |
e29372ff |
33 | sub _value_needs_copy { |
34 | my $self = shift; |
35 | |
36 | return $self->_constraint_must_be_checked |
37 | && !$self->_check_new_members_only; |
38 | } |
39 | |
a7821be5 |
40 | sub _inline_tc_code { |
41 | my ( $self, $new_value, $potential_value ) = @_; |
42 | |
43 | return q{} unless $self->_constraint_must_be_checked; |
44 | |
45 | if ( $self->_check_new_members_only ) { |
46 | return q{} unless $self->_adds_members; |
47 | |
48 | return $self->_inline_check_member_constraint($new_value); |
49 | } |
50 | else { |
b26c2595 |
51 | return $self->_inline_check_coercion( '\\' . $potential_value ) . "\n" |
52 | . $self->_inline_check_constraint( '\\' . $potential_value ); |
a7821be5 |
53 | } |
54 | } |
55 | |
56 | sub _constraint_must_be_checked { |
57 | my $self = shift; |
58 | |
59 | my $attr = $self->associated_attribute; |
60 | |
61 | return $attr->has_type_constraint |
62 | && ( $attr->type_constraint->name ne 'ArrayRef' |
63 | || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); |
64 | } |
65 | |
66 | sub _check_new_members_only { |
67 | my $self = shift; |
68 | |
69 | my $attr = $self->associated_attribute; |
70 | |
71 | my $tc = $attr->type_constraint; |
72 | |
73 | # If we have a coercion, we could come up with an entirely new value after |
74 | # coercing, so we need to check everything, |
75 | return 0 if $attr->should_coerce && $tc->has_coercion; |
76 | |
77 | # If the parent is ArrayRef, that means we can just check the new members |
78 | # of the collection, because we know that we will always be generating an |
e29372ff |
79 | # ArrayRef. However, if this type has its own constraint, we don't know |
80 | # what the constraint checks, so we need to check the whole value, not |
81 | # just the members. |
2e025511 |
82 | return 1 |
83 | if $tc->parent->name eq 'ArrayRef' |
b26c2595 |
84 | && $tc->isa('Moose::Meta::TypeConstraint::Parameterized'); |
a7821be5 |
85 | |
a7821be5 |
86 | return 0; |
87 | } |
88 | |
89 | sub _inline_check_member_constraint { |
90 | my ( $self, $new_value ) = @_; |
91 | |
92 | my $attr_name = $self->associated_attribute->name; |
93 | |
94 | return '$member_tc->($_) || ' |
95 | . $self->_inline_throw_error( |
96 | qq{"A new member value for '$attr_name' does not pass its type constraint because: "} |
97 | . ' . $member_tc->get_message($_)', |
98 | "data => \$_" |
99 | ) . " for $new_value;"; |
100 | } |
101 | |
102 | sub _inline_check_coercion { |
103 | my ( $self, $value ) = @_; |
104 | |
105 | my $attr = $self->associated_attribute; |
106 | |
107 | return '' |
108 | unless $attr->should_coerce && $attr->type_constraint->has_coercion; |
109 | |
110 | # We want to break the aliasing in @_ in case the coercion tries to make a |
111 | # destructive change to an array member. |
112 | my $code = 'my @copy = @{ $value }'; |
113 | return '@_ = @{ $attr->type_constraint->coerce(\@copy) };'; |
114 | } |
115 | |
116 | sub _inline_check_constraint { |
117 | my $self = shift; |
118 | |
119 | return q{} unless $self->_constraint_must_be_checked; |
120 | |
b26c2595 |
121 | return $self->SUPER::_inline_check_constraint( $_[0] ); |
a7821be5 |
122 | } |
123 | |
124 | sub _capture_old_value { return q{} } |
5df54980 |
125 | |
126 | sub _inline_set_new_value { |
127 | my ( $self, $inv, $new ) = @_; |
128 | |
129 | return $self->SUPER::_inline_store( |
130 | $inv, |
131 | $self->_value_needs_copy ? '\\' . $new : '[' . $new . ']' |
132 | ); |
133 | } |
134 | |
5fd49a51 |
135 | sub _return_value { return q{} } |
a7821be5 |
136 | |
137 | sub _eval_environment { |
138 | my $self = shift; |
139 | |
140 | my $env = $self->SUPER::_eval_environment; |
141 | |
142 | return $env |
143 | unless $self->_constraint_must_be_checked |
144 | and $self->_check_new_members_only; |
145 | |
146 | $env->{'$member_tc'} |
147 | = \( $self->associated_attribute->type_constraint->type_parameter |
148 | ->_compiled_type_constraint ); |
149 | |
150 | return $env; |
151 | } |
152 | |
f7fd22b6 |
153 | 1; |