Commit | Line | Data |
44babf1f |
1 | package Moose::Meta::Method::Accessor::Native::Collection; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
d874ffad |
6 | our $VERSION = '1.20'; |
44babf1f |
7 | $VERSION = eval $VERSION; |
8 | our $AUTHORITY = 'cpan:STEVAN'; |
9 | |
8b9641b8 |
10 | use Moose::Role; |
11 | |
12 | requires qw( _adds_members ); |
13 | |
7bf5e58d |
14 | around _inline_coerce_new_values => sub { |
15 | shift; |
16 | my $self = shift; |
17 | |
18 | return q{} unless $self->associated_attribute->should_coerce; |
19 | |
20 | return q{} unless $self->_tc_member_type_can_coerce; |
21 | |
22 | return |
23 | '(' |
24 | . $self->_new_members |
25 | . ') = map { $member_tc_obj->coerce($_) } ' |
26 | . $self->_new_members . ';'; |
27 | }; |
28 | |
29 | sub _tc_member_type_can_coerce { |
30 | my $self = shift; |
31 | |
32 | my $member_tc = $self->_tc_member_type; |
33 | |
34 | return $member_tc && $member_tc->has_coercion; |
35 | } |
36 | |
37 | sub _tc_member_type { |
38 | my $self = shift; |
39 | |
40 | for ( |
41 | my $tc = $self->associated_attribute->type_constraint; |
42 | $tc; |
43 | $tc = $tc->parent |
44 | ) { |
45 | |
46 | return $tc->type_parameter |
47 | if $tc->can('type_parameter'); |
48 | } |
49 | |
50 | return; |
51 | } |
52 | |
8b9641b8 |
53 | around _value_needs_copy => sub { |
44babf1f |
54 | shift; |
55 | my $self = shift; |
56 | |
57 | return $self->_constraint_must_be_checked |
58 | && !$self->_check_new_members_only; |
8b9641b8 |
59 | }; |
44babf1f |
60 | |
8b9641b8 |
61 | around _inline_tc_code => sub { |
44babf1f |
62 | shift; |
63 | my ( $self, $potential_value ) = @_; |
64 | |
65 | return q{} unless $self->_constraint_must_be_checked; |
66 | |
67 | if ( $self->_check_new_members_only ) { |
68 | return q{} unless $self->_adds_members; |
69 | |
70 | return $self->_inline_check_member_constraint( $self->_new_members ); |
71 | } |
72 | else { |
73 | return $self->_inline_check_coercion($potential_value) . "\n" |
74 | . $self->_inline_check_constraint($potential_value); |
75 | } |
8b9641b8 |
76 | }; |
44babf1f |
77 | |
78 | sub _check_new_members_only { |
79 | my $self = shift; |
80 | |
81 | my $attr = $self->associated_attribute; |
82 | |
83 | my $tc = $attr->type_constraint; |
84 | |
85 | # If we have a coercion, we could come up with an entirely new value after |
86 | # coercing, so we need to check everything, |
87 | return 0 if $attr->should_coerce && $tc->has_coercion; |
88 | |
89 | # If the parent is our root type (ArrayRef, HashRef, etc), that means we |
90 | # can just check the new members of the collection, because we know that |
91 | # we will always be generating an appropriate collection type. |
92 | # |
93 | # However, if this type has its own constraint (it's Parameteriz_able_, |
94 | # not Paramet_erized_), we don't know what is being checked by the |
95 | # constraint, so we need to check the whole value, not just the members. |
96 | return 1 |
97 | if $self->_is_root_type( $tc->parent ) |
98 | && $tc->isa('Moose::Meta::TypeConstraint::Parameterized'); |
99 | |
100 | return 0; |
101 | } |
102 | |
103 | sub _inline_check_member_constraint { |
104 | my ( $self, $new_value ) = @_; |
105 | |
106 | my $attr_name = $self->associated_attribute->name; |
107 | |
108 | return '$member_tc->($_) || ' |
109 | . $self->_inline_throw_error( |
110 | qq{"A new member value for '$attr_name' does not pass its type constraint because: "} |
ea829e77 |
111 | . ' . $member_tc_obj->get_message($_)', |
44babf1f |
112 | "data => \$_" |
113 | ) . " for $new_value;"; |
114 | } |
115 | |
8b9641b8 |
116 | around _inline_get_old_value_for_trigger => sub { |
44babf1f |
117 | shift; |
118 | my ( $self, $instance ) = @_; |
119 | |
120 | my $attr = $self->associated_attribute; |
121 | return '' unless $attr->has_trigger; |
122 | |
44babf1f |
123 | return |
d67398ab |
124 | 'my @old = ' |
125 | . $self->_inline_has($instance) . q{ ? } |
44babf1f |
126 | . $self->_inline_copy_old_value( $self->_inline_get($instance) ) |
d67398ab |
127 | . ": ();\n"; |
8b9641b8 |
128 | }; |
44babf1f |
129 | |
8b9641b8 |
130 | around _eval_environment => sub { |
44babf1f |
131 | my $orig = shift; |
132 | my $self = shift; |
133 | |
134 | my $env = $self->$orig(@_); |
135 | |
7bf5e58d |
136 | my $member_tc = $self->_tc_member_type; |
137 | |
138 | return $env unless $member_tc; |
139 | |
140 | $env->{'$member_tc_obj'} = \($member_tc); |
44babf1f |
141 | |
7bf5e58d |
142 | $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint ); |
44babf1f |
143 | |
144 | return $env; |
8b9641b8 |
145 | }; |
44babf1f |
146 | |
147 | no Moose::Role; |
148 | |
149 | 1; |