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 _new_value {'@_'} |
a7821be5 |
16 | |
e29372ff |
17 | sub _value_needs_copy { |
18 | my $self = shift; |
19 | |
20 | return $self->_constraint_must_be_checked |
21 | && !$self->_check_new_members_only; |
22 | } |
23 | |
a7821be5 |
24 | sub _inline_tc_code { |
25 | my ( $self, $new_value, $potential_value ) = @_; |
26 | |
27 | return q{} unless $self->_constraint_must_be_checked; |
28 | |
29 | if ( $self->_check_new_members_only ) { |
30 | return q{} unless $self->_adds_members; |
31 | |
32 | return $self->_inline_check_member_constraint($new_value); |
33 | } |
34 | else { |
e32b7489 |
35 | return $self->_inline_check_coercion($potential_value) . "\n" |
36 | . $self->_inline_check_constraint($potential_value); |
a7821be5 |
37 | } |
38 | } |
39 | |
a7821be5 |
40 | sub _check_new_members_only { |
41 | my $self = shift; |
42 | |
43 | my $attr = $self->associated_attribute; |
44 | |
45 | my $tc = $attr->type_constraint; |
46 | |
47 | # If we have a coercion, we could come up with an entirely new value after |
48 | # coercing, so we need to check everything, |
49 | return 0 if $attr->should_coerce && $tc->has_coercion; |
50 | |
51 | # If the parent is ArrayRef, that means we can just check the new members |
52 | # of the collection, because we know that we will always be generating an |
e29372ff |
53 | # ArrayRef. However, if this type has its own constraint, we don't know |
54 | # what the constraint checks, so we need to check the whole value, not |
55 | # just the members. |
2e025511 |
56 | return 1 |
57 | if $tc->parent->name eq 'ArrayRef' |
b26c2595 |
58 | && $tc->isa('Moose::Meta::TypeConstraint::Parameterized'); |
a7821be5 |
59 | |
a7821be5 |
60 | return 0; |
61 | } |
62 | |
63 | sub _inline_check_member_constraint { |
64 | my ( $self, $new_value ) = @_; |
65 | |
66 | my $attr_name = $self->associated_attribute->name; |
67 | |
68 | return '$member_tc->($_) || ' |
69 | . $self->_inline_throw_error( |
70 | qq{"A new member value for '$attr_name' does not pass its type constraint because: "} |
71 | . ' . $member_tc->get_message($_)', |
72 | "data => \$_" |
73 | ) . " for $new_value;"; |
74 | } |
75 | |
a7821be5 |
76 | sub _inline_check_constraint { |
77 | my $self = shift; |
78 | |
79 | return q{} unless $self->_constraint_must_be_checked; |
80 | |
b26c2595 |
81 | return $self->SUPER::_inline_check_constraint( $_[0] ); |
a7821be5 |
82 | } |
83 | |
e32b7489 |
84 | sub _inline_get_old_value_for_trigger { |
85 | my ( $self, $instance ) = @_; |
5df54980 |
86 | |
e32b7489 |
87 | my $attr = $self->associated_attribute; |
88 | return '' unless $attr->has_trigger; |
89 | |
90 | my $mi = $attr->associated_class->get_meta_instance; |
91 | my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name ); |
5df54980 |
92 | |
e32b7489 |
93 | return |
94 | 'my @old = ' |
95 | . $pred . q{ ? } . '[ @{' |
96 | . $self->_inline_get($instance) |
97 | . '} ] : ()' . ";\n"; |
5df54980 |
98 | } |
99 | |
a7821be5 |
100 | sub _eval_environment { |
101 | my $self = shift; |
102 | |
103 | my $env = $self->SUPER::_eval_environment; |
104 | |
105 | return $env |
106 | unless $self->_constraint_must_be_checked |
107 | and $self->_check_new_members_only; |
108 | |
109 | $env->{'$member_tc'} |
110 | = \( $self->associated_attribute->type_constraint->type_parameter |
111 | ->_compiled_type_constraint ); |
112 | |
113 | return $env; |
114 | } |
115 | |
f7fd22b6 |
116 | 1; |