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